Dokumentschriftarten finden und (einfach) ersetzen in CDR X6?

[fremoikaner]

Hallo!
Danke für die schnelle Reaktion :-)
So habe ich mir das Makro angepasst:

Code:

Sub textFont1()
   Dim p As Page, s As Shape, sr As ShapeRange
   Dim i&, f$, fNew$
 
   f = "Arial" 'your font to find
   fNew = "1451_Eng_DB" 'new font
 
   i = ActivePage.Index
   For Each p In ActiveDocument.Pages
       p.Activate
       Set sr = ActivePage.Shapes.FindShapes(Query:="@type = 'text:artistic'or @type = 'text:paragraph' and @com.text.story.font = '" & f & "'")
       For Each s In sr
           s.Text.Story.Font = fNew
       Next s
   Next p
   ActiveDocument.Pages(i).Activate
End Sub

Wie geschrieben ersetzt er aber alle(!) Schriften.

Gruß
fremoikaner

[koter]

Hallo fremoikaner,

Mit X7 funktioniert Dein Code.

Ich nehme an, dass X3 Die CQL-Query nicht richtig
auswerten kann und deswegen alles ersetzt.

Du kannst versuchen Die Überprüfung der zu ersetzenden Schriftart in die Schleife zu packen:

Code:

Sub textFont1a()
  Dim p As Page, s As Shape, sr As ShapeRange
  Dim i&, f$, fNew$

  f = "Arial" 'your font to find
  fNew = "1451_Eng_DB" 'new font

  i = ActivePage.Index
  For Each p In ActiveDocument.Pages
      p.Activate
      Set sr = ActivePage.Shapes.FindShapes(Type:=cdrTextShape) 'alle Texte suchen
      For Each s In sr
          If s.Text.Story.Font = f Then 'Schriftart prüfen
             s.Text.Story.Font = fNew
          End If
      Next s
  Next p
  ActiveDocument.Pages(i).Activate
End Sub

Das könnte den Ablauf etwas langsamer machen,
aber vielleicht kommt X3 damit zurecht.

Gruß

Koter

[fremoikaner]

Hallo koter,

super - so funzt es perfekt :-) Danke!

Ich habe noch die Schriftgröße ergänzt:

Code:

Sub textFont1a()
 Dim p As Page, s As Shape, sr As ShapeRange
 Dim i&, f$, fNew$

 f = "Arial" 'your font to find
 fNew = "1451_Eng_DB" 'new font

 i = ActivePage.Index
 For Each p In ActiveDocument.Pages
     p.Activate
     Set sr = ActivePage.Shapes.FindShapes(Type:=cdrTextShape) 'alle Texte suchen
     For Each s In sr
         If s.Text.Story.Font = f Then 'Schriftart prüfen
           If s.Text.Story.Size = 5.7 Then
              s.Text.Story.Font = fNew
           End If
         End If
     Next s
 Next p
 ActiveDocument.Pages(i).Activate
End Sub

Kann ich Dir ein Bier ausgeben?
Gruß
fremoikaner

[koter]

Hallo fremoikaner,

Kann ich Dir ein Bier ausgeben?

vielen Dank! Ist aber nicht nötig.
(habe noch welches im Keller)

Gruß

Koter