להורדה | תוסף עיצוב תורני לוורד

m.g

@pcinfogmach מודה מאוד על יצירת הפאר, על עדינות המראה, ובעיקר על הנגשתה לכלל הציבור.
יגדיל תורה ויאדיר

menajemmendel

יונתן 2

@pcinfogmach
תודה רבה מאוד, כבר יצא לי לשימוש,
לדעתי בגירסה 5 כדאי לשלב גם את זה (אם לא יהיה התנגשויות וכדומה):
https://tchumim.com/topic/6301/מאקרו-לתיקון-שגיאות-נפוצות

שליו

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

pcinfogmach

תודה רבה ל @m-g ולכולם על הפירגון כל כך נחמד להיות חבר בפורום שכזה שכולם מחמיאים כל כך יפה אחד לשני. אשריכם ישראל.

עוד נקודה:

@שליו כתב בלהורדה | תוסף חדש לוורד - עיצוב ספרי קודש:

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

רק רציתי לחזק את דברי @שליו

באמת שהמאקרו נועד לתועלת הציבור והא חינמי כך שאין שום בעיה לשנותו ולהוסיף עליו ואדרבה כן מומלץ לעשות ולהפיץ את השינויים שלכם הלאה - יהיה בכך תועלת גדולה לכולם. כמו"כ אשמח אם תעלו לכאן כל שינוי שתעשו - לתועלת העניין, (ולא להתבייש ממני אם החלטתם לעשות חלק מהדברים אחרת ממני, אדרבה מתוך רוב דעות יוצא כלי יקר).

simcha33345

@pcinfogmach

לשנותו ולהוסיף עליו ואדרבה כן מומלץ לעשות ולהפיץ את השינויים שלכם הלאה

כדאי מאוד שמי שמבצע שינוי ומשתף כאן.
שיכתוב מסודר מספר גרסה מהיצירה שלו ותאריך.
וכן איזה עדכונים / שינויים הכניס לקובץ.
כדי שלא יתבלבלו כאן באם יעלו מספר גרסאות מכמה אנשים..

pcinfogmach

בלי נדר אם רוצים אעדכן את מה שמעלים גם בפוסט הראשון בצורה מסודרת

האדם החושב

העליתי גירסא משלי כאן

pcinfogmach

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

העליתי גירסא משלי כאן

נפלא!
הוספתי קישור גם בפוסט המקורי
אני מחכה כבר לבא בתור שיתפוש את היוזמה

חשבתי אולי אפשר להקים צוות שיעבוד בצורה מסודרת על העניין
מי שמעוניין שיפנה אלי בבקשה בצ'אט או במייל

pcinfogmach

שאלה לציבור היקר:
לגבי עיצוב מילה ראשונה מישהו יודע אם מקובל לעצב גם בפיסקה עם שורה אחת?
האם יש פעמים שלא מקובל לעצב בפיסקה עם שני שורות?

ועוד שאלה כללית יותר:
מה עדיף: קוד משוכלל, או קוד מהיר?

עולה במסילה

@pcinfogmach קוד משוכלל ללא ספק
ואני יסביר כל מה שהיה עד היום לא יכולת להוסיף מילה אחת אחרי העיצוב כי כל וד"ל

pcinfogmach

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

כל מה שהיה עד היום לא יכולת להוסיף מילה אחת אחרי העיצוב

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

עולה במסילה

@pcinfogmach על איזה תוספים אתה מדבר? אשמח לדעת
תודה

pcinfogmach

@עולה-במסילה
עזרים לוורד לדוגמא
יצא כעת גירסה חדשה
עזרים לוורד
(סיסמה: WA123)

pcinfogmach

@pcinfogmach כתב בלהורדה | תוסף חדש לוורד - עיצוב ספרי קודש:

@עולה-במסילה
עזרים לוורד לדוגמא
יצא כעת גירסה חדשה
עזרים לוורד
(סיסמה: WA123)

שימו לב! ציילום מסך מתוך המדריך של התוסף עזרים לוורד

מצו"ב גם המדריך
עזרים לוורד.pdf

pcinfogmach

@menajemmendel כתב בלהורדה | תוסף חדש לוורד - עיצוב ספרי קודש:

@pcinfogmach תודה רבה, אפשר לראות את הקוד של מילת פתיח?
האם אפשר לקבל את הקוד בבקשה

שים לב הקוד עודכן https://mitmachim.top/post/629854

כמו"כ כתבתי לך בפוסט הנ"ל איך לשנות את הקוד כדי שיהיה איך שרצית על ידי החלת סגנון ולא על ידי העתק הדבק.

pcinfogmach

@menajemmendel לגבי הקוד של מילת פתיח בוורד

הקוד שונה שוב באופן מהותי ועודכן בפוסט הנ"ל
https://mitmachim.top/post/629854

כמו"כ נוספו קודים להוספת והחלת סגנון

menajemmendel

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

ראיתי שחלק מהאריכות נובעת בגלל השאלות של אם רוצים לתקן גם שורות בנות 2 שורות, אז למה שלא תעשה מאקרו יותר פשוט, (אולי לך לא מפריע שהוא מורכב כי אתה יותר מומחה) ותעשה שהמקרו יעבוד על כל הפסיקאות כולל את אלה של 2 שורות, ותעשה מקרו אחר נוסף שיחפש את כל הפסקאות בנות שתי שורות ויבטל מהם התיקון, (שהרי יש לך כבר מאקרו שמבטל עיצוב על אותו פיסקה לבד)
הנה לך הקוד


Sub ONLY_TWO_LINES()
'מחפש פיסקאות שהם שתים או פחות
    Dim PISKA As Paragraph
    For Each PISKA In ActiveDocument.Paragraphs
        If PISKA.Range.ComputeStatistics(wdStatisticLines) <= 2 Then
            PISKA.Range.Select
            'call המאקרו לתיקון שאתה רוצה
        End If
    Next PISKA
End Sub

מקווה שיעזור לך לחסוך עבודה, שאוכל להחזיר לך קצת טובה ממה שאתה מטיב אתנו

האמת שלמה שכבר כתבת אין צורך שתחליף, אבל הרעיון שלי יכול לחסוך לך עבודה בדברים שתכתוב בעתיד

pcinfogmach

@menajemmendel

לפני הכול
ייש"כ על המשוב כמה טוב לראות אנשים שאיכפת להם.
ואיזה ענוות חן במילותיך

לגבי הקוד הנ"ל היה צורך לערוך בו איזהו שינוי.

הסיבה העיקרית לאריכות הגדולה בקודים היא בגלל שהקודים מטפלים בכל מיני בעיות שעלולות לצוץ תוכ"ד הרצת הקוד. ותאמין לי שהיה המון בעיות......

לגבי השאלות שכבודו הזכיר הרעיון שלך באמת רעיון מוצלח, השאלות עצמם הם סה"כ כמה שורות פשוטות בקוד - וכמו שכתבת אינם הכרחיות כלל ואפשר להסתדר בלעדיהם (אגב הם נמצאים רק בחלק מהקודים לפי שיקול דעת של חוויית המשתמש). בתכל'ס זה קודים שנמצאים מוכנים אצלי כך שאני כל פעם עושה העתק הדבק אז זה יותר קל לי כך.

אבקש את מחילת הציבור אם הקודים שלי מדי מסורבלים - גם חסר בהם את ההסברים הנצרכים. פשוט אחרי כל כך הרבה גלגולים של הקוד של מה עובד ומה עלול ליצור בעיות (הקוד הכי מושלם עלול ליצור בעיות במצבים מסויימים) נגמר הכוח לסדר הכול אח"כ.

pcinfogmach

@menajemmendel
אולי לצורך העניין ניקח קוד אחד ארוך ומסורבל וננתח אותו יחדיו.
אז הנה הקוד לעיצוב מילה ראשונה על כל המסמך ולאחריו יבוא ניתוח הקוד.

Sub FirstWordFormatWholeDoc()
'
'עיצוב מילה ראשונה בכל המסמך
'מאת pcinfogmach
'
'

    ' Declare variables
    Dim para As Paragraph
    Dim paraText As String
    Dim numSpaces As Integer
    Dim spacePos As Long
    Dim startSel As Long
    Dim endSel As Long
    Dim i As Integer
    Dim paraRange As Range
    Dim skpit As Boolean
    Dim solveletters As VbMsgBoxResult
    
    ' Get number of spaces
    numSpaces = 1
    
    'טיפול בפיסקאות עם שורה אחת או שנים
    Dim include1Line As Boolean
    Dim include2Line As Boolean
    
    include1Line = MsgBox("האם ברצונך לכלול פיסקאות עם שורה אחת?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "הסרת עיצוב מילה ראשונה מאת - pcinfogmach") = vbNo
    If include1Line Then
    include2Line = MsgBox("האם ברצונך לכלול פיסקאות עם 2 שורות?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "הסרת עיצוב מילה ראשונה מאת - pcinfogmach") = vbNo
    End If
    
    'טווח הפעולה
    Selection.WholeStory
    Dim slctd As Range
    Set slctd = Selection.Range
    slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
      
    'הכנות וטיפול בבעיות
    Application.ScreenUpdating = False
    Dim ftntstyl As String
    ActiveWindow.View.SeekView = wdSeekMainDocument
    Selection.Move wdCharacter, 1
    ActiveDocument.Footnotes.Add Range:=Selection.Range, _
    Text:="דוגמא."
    Selection.MoveEnd wdCharacter, 1
    ftntstyl = Selection.Range.Style.NameLocal 'Get the name of the current style
    Selection.Delete Unit:=wdCharacter, count:=1
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    slctd.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    
    slctd.Find.Execute FindText:="^f", ReplaceWith:="^&^p", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:=Chr(13) & ChrW(8194), ReplaceWith:="^&^p", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="([!^13])(^2)(^13)", ReplaceWith:="\1\2", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll

    'תחילת הלולאה
    slctd.Select
    For Each para In slctd.Paragraphs
    
    'החרגות
    If para.Range.Style Like "כותרת*" Then GoTo nxt
    If para.Range.Style Like "Heading*" Then GoTo nxt
    If Not para.Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then GoTo nxt
    If Not para.Range.ComputeStatistics(wdStatisticLines) <> 1 And include1Line Then GoTo nxt
    If Not para.Range.ComputeStatistics(wdStatisticLines) <> 2 And include2Line Then GoTo nxt
 
            ' Get text of paragraph
            paraText = para.Range.Text
            
            ' Find position of first space
            spacePos = InStr(1, paraText, " ")
            
            ' Find position of selected space
            For i = 2 To numSpaces
                spacePos = InStr(spacePos + 1, paraText, " ")
                If spacePos = 0 Then Exit For
            Next i
            
            ' Select words
            If Not spacePos > 0 Then GoTo nxt
                startSel = para.Range.Start
                endSel = startSel + spacePos
                Selection.SetRange Start:=startSel, End:=endSel

Application.ScreenUpdating = True
Application.ScreenRefresh

'טיפול בסימוני סימנים ופרקים
If solveletters = vbNo Then GoTo skp
If Mid(Selection.Range.Text, Len(Selection.Text) - 1, 1) = Chr(93) Or Mid(Selection.Text, Len(Selection.Text) - 1, 1) = Chr(41) Then
Application.ScreenRefresh
If solveletters = vbYes Then GoTo doit
       solveletters = MsgBox("ייתכן שהמילה הראשונה משמשת כסימון של סימנים או פרקים. האם להרחיב את העיצוב עד למילה השנייה?", _
       vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה")
If solveletters = vbNo Then GoTo skp
doit:
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "* * "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        .Execute
    End With
skp:
End If


'מעקף עבור שאר הפיסקאות חוץ מהראשונה
If skpit = True Then GoTo rst

'בחירת העיצוב
  Selection.Font.Name = Selection.Font.Name
    With Dialogs(wdDialogFormatFont)
    .Update
        .Font = Selection.Font.Name
        .FontNameBi = Selection.Font.Name
        If .Show = False Then GoTo endr
    End With
       
    Selection.CopyFormat
    skpit = True
    Application.ScreenRefresh
    GoTo nxt

'החלת העיצוב בשאר הפיסקאות
rst:
Selection.PasteFormat
Application.ScreenRefresh
nxt:
    Next para
endr:

'ניקוי שאריות
slctd.Find.Execute FindText:=ChrW(8194) & Chr(13), ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
slctd.Find.Execute FindText:="(^2)^13", ReplaceWith:="\1", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    On Error Resume Next
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        ftntstyl)
    With Selection.Find
        .Text = "^2"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    On Error GoTo 0
    
'מניעת שגיאות
Application.ScreenRefresh

End Sub

אז בואו נתחיל בניתוח הקוד:

הקוד פותח בהצהרת משתנים רבים

    Dim para As Paragraph
    Dim paraText As String
    Dim numSpaces As Integer
    Dim spacePos As Long
    Dim startSel As Long
    Dim endSel As Long
    Dim i As Integer
    Dim paraRange As Range
    Dim skpit As Boolean
    Dim solveletters As VbMsgBoxResult

האמת היא שהיה יכול להיות הרבה פחות משנים וכך היה במקור. לדוגמא המשתנה של Dim i As Integer אינו הכרחי בקוד זה כלל והוא נמצא כאן רק בגלל שהשתמשתי עם אותו הקוד גם בוריאציה אחרת והיה לי יותר קל להשאיר אותו מאשר להתחיל לשנות את הקוד.

כמו"כ חלק מהמשתנים נולדו מתוך הצורך לזהות פיסקאות בעיתיות תוכ"ד הרצת הקוד (פיסקאות בלי רווחים). אפשר היה לעשות זאת בצורה אחרת אבל הצורה הזו הכי מהירה מבחינת קוד (אז מה עדיף קוד ברור או משוכלל? אני מעדיף משוכלל).

' Get number of spaces
    numSpaces = 1

שורה זו מיותרת לחלוטין ונולדה מתוך הסיבה הנ"ל שהקוד משמש גם בוריאתיות אחרות אז במקום לשנות את מבנה הקוד ולמחוק אותה פשוט קימבנתי משהו.

'טיפול בפיסקאות עם שורה אחת או שנים
    Dim include1Line As Boolean
    Dim include2Line As Boolean
    
    include1Line = MsgBox("האם ברצונך לכלול פיסקאות עם שורה אחת?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "הסרת עיצוב מילה ראשונה מאת - pcinfogmach") = vbNo
    If include1Line Then
    include2Line = MsgBox("האם ברצונך לכלול פיסקאות עם 2 שורות?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "הסרת עיצוב מילה ראשונה מאת - pcinfogmach") = vbNo
    End If

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

 Selection.WholeStory
    Dim slctd As Range
    Set slctd = Selection.Range

ארוך ומסורבל היה אפשר להגדיר שהrange יהיה על כל המסמך. אבל זה יצר בעיות ההערות שוליים. כי הקוד רץ גם עליהם ורציתי שיוכלו להריץ אותו בנפרד על הטקסט הראשי ועל ההערות שוליים.

 slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

שורה זו של הקוד אינה נצרכת מצד המטרה העיקרית של הקוד. היא בעצם הקדמה לפקודות חיפוש והחלפה שבהמשך כדי למנוע מהם לחול על כל המסמך ולפעול במקומות שלא רציתי שיפעלו.

'הכנות וטיפול בבעיות
    Application.ScreenUpdating = False
    Dim ftntstyl As String
    ActiveWindow.View.SeekView = wdSeekMainDocument
    Selection.Move wdCharacter, 1
    ActiveDocument.Footnotes.Add Range:=Selection.Range, _
    Text:="דוגמא."
    Selection.MoveEnd wdCharacter, 1
    ftntstyl = Selection.Range.Style.NameLocal 'Get the name of the current style
    Selection.Delete Unit:=wdCharacter, count:=1

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

Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    slctd.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    
    slctd.Find.Execute FindText:="^f", ReplaceWith:="^&^p", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:=Chr(13) & ChrW(8194), ReplaceWith:="^&^p", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    slctd.Find.Execute FindText:="([!^13])(^2)(^13)", ReplaceWith:="\1\2", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll

סוללה של חיפוש והחלפה שמיועדת להכין את המסמך כדי לשא יהיו בעיות בהחלת העיצוב. הבעיות האלה בעיקר נולדות בהערות שוליים מתוך העובדה שהמילה הראשונה בהם היא בעצם הסימון של ההערות שוליים. יש כמה חיפושים שהם בעצם הכנה לחיפוש שאחריו ויש מהם שפותרים שאריות מחיפושים כושלים. ויש מהם שמוסיפים מעבר פיסקה אחרי הסימון ועוד (סלחיה אבל אין לי כח לפרט הכל).

'תחילת הלולאה
    slctd.Select
    For Each para In slctd.Paragraphs

השורה שקודמת תיצירת הלולאה נולדה מתוך כך שיצאנו מתוך הטווח כדי לפתור כל מיני בעיות אז עכשיו אנו חוזרים אליו ומתחילים את הלולאה שתרוץ על כל הפיסקאות של המסמך

  'החרגות
    If para.Range.Style Like "כותרת*" Then GoTo nxt
    If para.Range.Style Like "Heading*" Then GoTo nxt
    If Not para.Range.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then GoTo nxt
    If Not para.Range.ComputeStatistics(wdStatisticLines) <> 1 And include1Line Then GoTo nxt
    If Not para.Range.ComputeStatistics(wdStatisticLines) <> 2 And include2Line Then GoTo nxt

חלק זה מדבר בעד עצמו רוב הפקודות הם אותו עיקרון אם תשימו לב.

            ' Get text of paragraph
            paraText = para.Range.Text
            
            ' Find position of first space
            spacePos = InStr(1, paraText, " ")
            
            ' Find position of selected space
            For i = 2 To numSpaces
                spacePos = InStr(spacePos + 1, paraText, " ")
                If spacePos = 0 Then Exit For
            Next i
            
            ' Select words
            If Not spacePos > 0 Then GoTo nxt
                startSel = para.Range.Start
                endSel = startSel + spacePos

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

      Selection.SetRange Start:=startSel, End:=endSel

סימון הטווח שקבענו

Application.ScreenUpdating = True
Application.ScreenRefresh

כדי שלא לבלבל את המשתמשים עד עכשיו הסתרנו את פעולת הקוד מעיני המשתמש, כדי שהמשתמש לא יאבד סבלנות מכאן ואילך אנחנו מראים למשתמש מה אנו עושים.
כמו"כ נוסף פקודת refresh כדי שהמשתמש יוכל לראות בעיניים את התקדמות העריכה. (אחרת במסמכים ארוכים הוא עלול לחשוב שהקוד תקע לו את התוכנה).

'טיפול בסימוני סימנים ופרקים
If solveletters = vbNo Then GoTo skp
If Mid(Selection.Range.Text, Len(Selection.Text) - 1, 1) = Chr(93) Or Mid(Selection.Text, Len(Selection.Text) - 1, 1) = Chr(41) Then
Application.ScreenRefresh
If solveletters = vbYes Then GoTo doit
       solveletters = MsgBox("ייתכן שהמילה הראשונה משמשת כסימון של סימנים או פרקים. האם להרחיב את העיצוב עד למילה השנייה?", _
       vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה")
If solveletters = vbNo Then GoTo skp
doit:
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "* * "
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .MatchWildcards = True
        .Execute
    End With
skp:
End If

קטע קוד זה אינו הכרחי כלל הוא נועד לטפל במקרה בו המילה הראשונה בפיסקה היא בעצם סימון אותיות של סימנים יא) יב) וכדו'. הקוד כאן מאוד מבלבל והסיבה היא כי רציתי ליצור קיצורי דרך בקוד שיאפשרו לקוד להיות יותר מהיר. כמו"כ קיצורי הדרך נועדו כדי לתת למשתמש לבחור בפעם הראושנה מה לעשות ובשאר הפעמים להמשיך עם הבחירה הראשונה.

'מעקף עבור שאר הפיסקאות חוץ מהראשונה
If skpit = True Then GoTo rst

בפיסקה הראשונה המשתמש נשאל איך הוא רוצה לעצב את המילה הראונה אין עניין שנשאל אותו כל פעם אז לזה צריך מעקף.

'בחירת העיצוב
  Selection.Font.Name = Selection.Font.Name
    With Dialogs(wdDialogFormatFont)
    .Update
        .Font = Selection.Font.Name
        .FontNameBi = Selection.Font.Name
        If .Show = False Then GoTo endr
    End With

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

    Selection.CopyFormat
    skpit = True
    Application.ScreenRefresh
    GoTo nxt

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

'החלת העיצוב בשאר הפיסקאות
rst:
Selection.PasteFormat
Application.ScreenRefresh
nxt:
    Next para
endr:

החלת העיצוב על שאר הפיסקאות סוף הלולאה, ונקודת כניסה של כמה מעקפים שיצרנו למעלה.

'ניקוי שאריות
slctd.Find.Execute FindText:=ChrW(8194) & Chr(13), ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
slctd.Find.Execute FindText:="(^2)^13", ReplaceWith:="\1", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll

מדבר בעד עצמו (מילה אחת של הסבר אולי כדי לפתור את הבעיה עם ההערות שוליים היה צורך ליצור כמה מעברי פיסקה מיותרים כאן אנו מסירים אותם).

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    On Error Resume Next
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        ftntstyl)
    With Selection.Find
        .Text = "^2"
        .Replacement.Text = "^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    On Error GoTo 0

תיקון הבעיה עם סימני הערות שוליים שהזכרנו למעלה

'מניעת שגיאות
Application.ScreenRefresh

לפעמים המסך נתקע בגמר המאקרו אז refresh פותר את הבעיה.

להורדה | תוסף עיצוב תורני לוורד

תוסף תורני לוורד - חינמי

גירסאות קודמות

תוסף תורני לוורד - חינמי

גירסאות קודמות

תוסף תורני לוורד - חינמי

גירסאות קודמות