בקשה | יצירת מאקרו חיפוש והחלפה לפי עיצוב ולא מילים

[זאב לבן]

@עולה-במסילה למה שלא תעבוד עם סגנונות?

[דאנציג]

@זאב-לבן
חשבתי להציע לו את זה, היות וזו הדרך הנכונה והקלה ביותר לעבוד עם וורד, אבל

@עולה-במסילה כתב בבקשה | יצירת מאקרו חיפוש והחלפה לפי עיצוב ולא מילים:

יש לי המון מסמכים שעיצבתי אותם פעם

ולעבור על מסמכים ישנים, ולבנות סגנונות וכו', זה הרבה יותר קשה מאשר חיפוש והחלפה או מאקרו.
אמנם אם הוא באמת רוצה, ניתן ליצור סגנונות, ולהעביר אותם למסמכים אחרים, (ואפשר גם חיצוני [בלי לפתוח קובץ קובץ], אבל רק על DOCX, ולא DOC)...

[עולה במסילה]

@זאב-לבן תודה רבה על המענה שלך
ובקשר למה שכתבת אני לא יכול לעבוד עם סגנונות כיון שזה פסקאות שבכל פסקה יש כמה גופנים ואם אני משנה סגנון כל הפיסקא משתנה ביחד לכן מה שאני צריך חיפוש והחלפה לפי גופן
תודה רבה

[עולה במסילה]

@יאיר-דניאל תודה רבה על הקוד שכתבת בשבילי
אבל זה לא נותן לי מענה מיידי כי אני צריך שהמאקרו יתן לי אפשרות לבחור איזה גופן ברצוני להחליף ואח"כ יתן לי את האופציה באיזה גופן לבחור
לאחר ניסיתי את הקוד שהבאת הוא נותן רק את האופציה לאיזה גופן לשנות אבל הוא משנה את כל המסמך ולא גופן ספציפי בגופן אחר
תודה רבה

[יאיר דניאל]

@עולה-במסילה אתה יכול לסמן קטע - ואז להפעיל את המאקרו - והוא יחליף רק את אותו הקטע

[עולה במסילה]

@יאיר-דניאל הבעיה היא שכל קטע מורכב משני גופנים כך שלעבוד על כל קטע בנפרד הוא כמו לעבוד על כל מסמך בנפרד ולהגדיר את הגופנים אותן אני מעונין להחליף...

[יאיר דניאל]

@עולה-במסילה הבנתי - אנסה לשפר את זה.

[יאיר דניאל]

@עולה-במסילה

הנה בכבוד:

Sub ReplaceSpecificFont()
    Dim docFonts As New Collection
    Dim targetFont As String
    Dim replacementFont As String
    Dim lastUsedFont As String
    Dim i As Long
    Dim fontChoice As String
    Dim answer As VbMsgBoxResult

    ' 1. סריקת המסמך לזיהוי פונטים קיימים
    On Error Resume Next
    Dim para As Paragraph
    For Each para In ActiveDocument.Paragraphs
        ' הוספת הגופן הרגיל והגופן העברי לאוסף
        If para.Range.Font.Name <> "" Then docFonts.Add para.Range.Font.Name, para.Range.Font.Name
        If para.Range.Font.NameBi <> "" Then docFonts.Add para.Range.Font.NameBi, para.Range.Font.NameBi
    Next para
    On Error GoTo 0

    If docFonts.Count = 0 Then
        MsgBox "לא נמצאו גופנים מזוהים.", vbExclamation
        Exit Sub
    End If

    ' 2. בחירת הגופן להחלפה
    Dim fontList As String
    fontList = "בחר מספר גופן להחלפה:" & vbCrLf
    For i = 1 To docFonts.Count
        fontList = fontList & i & ". " & docFonts(i) & vbCrLf
    Next i

    fontChoice = InputBox(fontList, "חפש והחלף גופן")
    If Not IsNumeric(fontChoice) Then Exit Sub
    i = CInt(fontChoice)
    If i < 1 Or i > docFonts.Count Then Exit Sub
    targetFont = docFonts(i)

    ' 3. בחירת גופן היעד
    lastUsedFont = GetSetting("MyWordMacros", "Settings", "LastFont", "David")
    answer = MsgBox("להחליף את " & targetFont & " ב-" & lastUsedFont & "?" & vbCrLf & _
                    "לחץ 'כן' לאישור, או 'לא' לבחירה מרשימה.", _
                    vbYesNoCancel + vbQuestion + vbMsgBoxRight + vbMsgBoxRtlReading)

    If answer = vbYes Then
        replacementFont = lastUsedFont
    ElseIf answer = vbNo Then
        With Application.Dialogs(wdDialogFormatFont)
            If .Show = -1 Then
                replacementFont = Selection.Font.NameBi
                If replacementFont = "" Or replacementFont = "0" Then replacementFont = Selection.Font.Name
            End If
        End With
    Else
        Exit Sub
    End If

    If replacementFont = "" Or replacementFont = "0" Then Exit Sub
    SaveSetting "MyWordMacros", "Settings", "LastFont", replacementFont

    ' 4. ביצוע ההחלפה (שיטה משופרת)
    Application.ScreenUpdating = False
    
    ' פקודת ההחלפה צריכה לרוץ פעמיים כדי לכסות גם עברית וגם אנגלית בוודאות
    Call ExecuteFontReplace(targetFont, replacementFont, True)  ' עבור עברית
    Call ExecuteFontReplace(targetFont, replacementFont, False) ' עבור אנגלית

    Application.ScreenUpdating = True
    Application.ScreenRefresh
    
    MsgBox "הפעולה הושלמה עבור הגופן: " & targetFont, vbInformation
End Sub

' פונקציית עזר לביצוע ההחלפה בפועל' פונקציית עזר לביצוע ההחלפה בפועל - עם שמות פרמטרים תקינים
Sub ExecuteFontReplace(fTarget As String, fReplace As String, isBi As Boolean)
    Dim r As Range
    Set r = ActiveDocument.Content
    
    r.Find.ClearFormatting
    r.Find.Replacement.ClearFormatting
    
    If isBi Then
        r.Find.Font.NameBi = fTarget
        r.Find.Replacement.Font.NameBi = fReplace
    Else
        r.Find.Font.Name = fTarget
        r.Find.Replacement.Font.Name = fReplace
    End If
    
    ' התיקון הקריטי: FindText במקום Text, ו-ReplaceWith במקום ReplacementText
    r.Find.Execute FindText:="", ReplaceWith:="", _
        Forward:=True, Wrap:=wdFindContinue, Format:=True, Replace:=wdReplaceAll
End Sub

זה עובד כך - תמונות בספויילר

Spoiler

[יאיר דניאל]

ואם אתה רוצה יותר משוכלל - שלא תצטרך להקליד אפילו את שם הגופן להחלפה - אז הנה.

פשוט תפעיל את הקובץ המצורף
החלפת גופנים.exe

או שתכניס את הקובץ הזה - לתיקיית הטמפלס של אופיס (הקובץ למעלה - עושה את זה אוטומטית)

החלפת גופנים.dotm

כך זה נראה:

המשך התהליך זהה למאקרו הקודם

[עולה במסילה]

@יאיר-דניאל תודה רבה אנסה את זה ואענה על כך בהמשך אין מילים...