Sub Linien_bearbeiten() 
'alle Linien mit den Farbwerten 0c0m0y100k und der Breite 0.1 bis 1 pt finden, 
'gefundenen Linien unterhalb der max_länge (per Dialog) ggf neue Linienbreite zuweisen 
 
  Dim sh As Shape 
  ActiveDocument.Unit = cdrMillimeter 
  ActiveDocument.ClearSelection 
  linienbreite = 0.05  'hier gewünschte neue Linienstärke in mm eingeben 
  max_länge = 20       'hier maximale linienlänge in mm angeben 
  Ansicht_nach_links = 80 'dieser Wert schiebt die Ansicht um x mm vom Zentrum nach links (ausprobieren) 
   
  For Each sh In ActivePage.Shapes.FindShapes(Query:="@type = 'curve' and @outline.color.cmyk[.c = 0 and .m = 0 and .y = 0 and .k = 100] and @outline[width <= {1 pt} and .width > {0.1 pt}]") 
    sh.Selected = True 
    ActiveWindow.ActiveView.SetViewPoint sh.CenterX + Ansicht_nach_links, sh.CenterY   'Zoomfaktor beibehalten 
    If sh.Curve.Length <= max_länge Then 
      antwort = MsgBox("Länge : " & sh.Curve.Length & vbCr _ 
      & "Farbe : " & sh.Outline.Color.CMYKCyan & "c " & sh.Outline.Color.CMYKMagenta & "m " & sh.Outline.Color.CMYKYellow & "y " & sh.Outline.Color.CMYKBlack & "k" & vbCr _ 
      & "Breite: " & sh.Outline.Width & vbCr & vbCr _ 
      & "Gefundene Linie ändern?", vbYesNoCancel) 
      If antwort = vbYes Then 
        sh.Outline.Width = linienbreite  'Linie ändern! 
      ElseIf antwort = vbNo Then 
        ' keine Änderung 
      Else 
        Exit Sub 
      End If 
    End If 
    sh.Selected = False 
  Next sh 
End Sub