Macros für Falt- und Lochmarken

Macros für Falt- und Lochmarken
Basierend auf diesem Artikel

Sub FaltmarkeEinfügen()
   'Die Länge des Striches beträgt 0,9 - 0,5 = 0,4 cm
   Dim oKz As HeaderFooter, FM As Shape
   savEnv = ActiveWindow.View
   Set oKz = ActiveDocument.Sections(1).Headers(1)
   On Error Resume Next
   Set FM = oKz.Shapes("RP200307241")
   If Not FM Is Nothing Then Exit Sub
   Set FM = oKz.Shapes.AddLine(CentimetersToPoints(0.5), _
   CentimetersToPoints(10.5), _
   CentimetersToPoints(0.9), _
   CentimetersToPoints(10.5))
   FM.Name = "RP200307241"
   FM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   FM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   FM.Line.Weight = 0.25
   FM.LockAnchor = True
   ActiveWindow.View = savEnv
End Sub

Sub FaltUndLochmarkeEinfügen()
   Dim oKz As HeaderFooter, FM As Shape, LM As Shape
   savEnv = ActiveWindow.View
   Set oKz = ActiveDocument.Sections(1).Headers(1)
   On Error Resume Next
   Set FM = oKz.Shapes("RP200307241")
   If FM Is Nothing Then
   'Die Länge des Striches (Faltmarke) beträgt 1,2 - 0,5 = 0,7 cm
   Set FM = oKz.Shapes.AddLine(CentimetersToPoints(0.5), _
   CentimetersToPoints(10.5), _
   CentimetersToPoints(1.2), _
   CentimetersToPoints(10.5))
   FM.Name = "RP200307241"
   FM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   FM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   FM.Line.Weight = 0.25
   FM.LockAnchor = True
   End If
   Set LM = oKz.Shapes("RP200307242")
   If LM Is Nothing Then
   'Die Länge des Striches (Lochmarke) beträgt 0,9 - 0,5 = 0,4 cm
   Set LM = oKz.Shapes.AddLine(CentimetersToPoints(0.5), _
   CentimetersToPoints(14.85), _
   CentimetersToPoints(0.9), _
   CentimetersToPoints(14.85))
   LM.Name = "RP200307242"
   LM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   LM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   LM.Line.Weight = 0.25
   LM.LockAnchor = True
   End If
   ActiveWindow.View = savEnv
End Sub

Sub FaltmarkeEinfügenNurErsteSeite()
   'Die Länge des Striches beträgt 0,9 - 0,5 = 0,4 cm
   Dim oKz As HeaderFooter, FM As Shape
   savEnv = ActiveWindow.View
   Rand = ActiveDocument.Sections(1).PageSetup.LeftMargin
   ActiveDocument.Sections(1).PageSetup.DifferentFirs tPageHeaderFooter = True
   Set oKz = ActiveDocument.Sections(1).Headers(wdHeaderFooterF irstPage)
   On Error Resume Next
   Set FM = oKz.Shapes("RP200307241")
   If Not FM Is Nothing Then Exit Sub
   Set FM = oKz.Shapes.AddLine(CentimetersToPoints(0.5) - Rand, _
   CentimetersToPoints(10.5), _
   CentimetersToPoints(0.9) - Rand, _
   CentimetersToPoints(10.5), oKz.Range)
   FM.Name = "RP200307241"
   FM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   FM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   FM.Line.Weight = 0.25
   FM.LockAnchor = True
   ActiveWindow.View = savEnv
End Sub

Sub FaltUndLochmarkeEinfügenNurErsteSeite()
   Dim oKz As HeaderFooter, FM As Shape, LM As Shape
   savEnv = ActiveWindow.View
   Rand = ActiveDocument.Sections(1).PageSetup.LeftMargin
   ActiveDocument.Sections(1).PageSetup.DifferentFirs tPageHeaderFooter = True
   Set oKz = ActiveDocument.Sections(1).Headers(wdHeaderFooterF irstPage)
   On Error Resume Next
   Set FM = oKz.Shapes("RP200307241")
   If FM Is Nothing Then
   'Die Länge des Striches (Faltmarke) beträgt 1,2 - 0,5 = 0,7 cm
   Set FM = oKz.Shapes.AddLine(CentimetersToPoints(0.5) - Rand, _
   CentimetersToPoints(10.5), _
   CentimetersToPoints(1.2) - Rand, _
   CentimetersToPoints(10.5), oKz.Range)
   FM.Name = "RP200307241"
   FM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   FM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   FM.Line.Weight = 0.25
   FM.LockAnchor = True
   End If
   Set LM = oKz.Shapes("RP200307242")
   If LM Is Nothing Then
   'Die Länge des Striches (Lochmarke) beträgt 0,9 - 0,5 = 0,4 cm
   Set LM = oKz.Shapes.AddLine(CentimetersToPoints(0.5) - Rand, _
   CentimetersToPoints(14.85), _
   CentimetersToPoints(0.9) - Rand, _
   CentimetersToPoints(14.85), oKz.Range)
   LM.Name = "RP200307242"
   LM.RelativeHorizontalPosition = wdRelativeHorizontalPositionPage
   LM.RelativeVerticalPosition = wdRelativeVerticalPositionPage
   LM.Line.Weight = 0.25
   LM.LockAnchor = True
   End If
   ActiveWindow.View = savEnv
End Sub

Sub AlleMarkenLoeschen()
   Dim oShape As Shape
   For i = 1 To 2
   For Each oShape In ActiveDocument.Sections(1).Headers(i).Shapes
   If InStr(oShape.Name, "RP20030724") = 1 Then oShape.Delete
   Next
   Next i
End Sub