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

[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 פותר את הבעיה.

[pcinfogmach]

בס"ד גירסה מס' 5 של תוסף עיצוב ספרי קודש יצא לאור:

עודכן בפוסט המקורי
https://mitmachim.top/post/626904

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

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

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

[שליו]

@pcinfogmach
הורדתי את הגרסה האחרונה אבל הקובץ ריק!

[pcinfogmach]

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

@pcinfogmach
הורדתי את הגרסה האחרונה אבל הקובץ ריק!

סליחה!
הקובץ עודכן כעת.

[simcha33345]

@pcinfogmach עדכון ענק!! כל הכבוד, שימחת אותי ועוד כמה חברים שלי... !!
הרבה סייעתא דשמיא..!!

[menajemmendel]

@pcinfogmach ממש יפה תודה

[dfhzrhree]

@pcinfogmach
אולי כדאי להוסיף (במסמך גופו) תמונה כעין זו, יען לא כל ברנש יבין מעצמו היכן מקומו של מקש ההתקנה, הלא כן?

[בוקר טוב]

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

[pcinfogmach]

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

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

כלומר פותח מסמך חדש ריק?
או שלא מפנה כלל?

[בוקר טוב]

@pcinfogmach פותח חדש ריק

[pcinfogmach]

@בוקר-טוב
תודה. אנסה לטפל בזה בגירסאות הבאות בלי נדר.

[pcinfogmach]

בקשת עזרה ביצירת מאקרו

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

אז איפה אני צריך עזרה?

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

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

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

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

Attribute VB_Name = "Module2"
Option Explicit

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


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

On Error Resume Next
    ActiveDocument.Styles.Add Name:="מילת פתיח עיצוב מהיר", Type:= _
    wdStyleTypeParagraph
    ActiveDocument.Styles("מילת פתיח עיצוב מהיר").AutomaticallyUpdate = False
    With ActiveDocument.Styles("מילת פתיח עיצוב מהיר").Font
        .Name = "+גוף"
        .Size = 11
        .Bold = False
        .Italic = False
        .Underline = wdUnderlineNone
        .UnderlineColor = wdColorAutomatic
        .StrikeThrough = False
        .DoubleStrikeThrough = False
        .Outline = False
        .Emboss = False
        .Shadow = False
        .Hidden = False
        .SmallCaps = False
        .AllCaps = False
        .Color = wdColorAutomatic
        .Engrave = False
        .Superscript = False
        .Subscript = False
        .Scaling = 100
        .Kerning = 1
        .Animation = wdAnimationNone
        .SizeBi = 11
        .NameBi = "Arial"
        .BoldBi = True
        .ItalicBi = False
        .Ligatures = wdLigaturesStandardContextual
        .NumberSpacing = wdNumberSpacingDefault
        .NumberForm = wdNumberFormDefault
        .StylisticSet = wdStylisticSetDefault
        .ContextualAlternates = 0
    End With
    With ActiveDocument.Styles("מילת פתיח עיצוב מהיר").ParagraphFormat
        .LeftIndent = CentimetersToPoints(0)
        .RightIndent = CentimetersToPoints(0)
        .SpaceBefore = 0
        .SpaceBeforeAuto = False
        .SpaceAfter = 8
        .SpaceAfterAuto = False
        .LineSpacingRule = wdLineSpaceMultiple
        .LineSpacing = LinesToPoints(1.08)
        .Alignment = wdAlignParagraphLeft
        .WidowControl = True
        .KeepWithNext = False
        .KeepTogether = False
        .PageBreakBefore = False
        .NoLineNumber = False
        .Hyphenation = True
        .FirstLineIndent = CentimetersToPoints(0)
        .OutlineLevel = wdOutlineLevelBodyText
        .CharacterUnitLeftIndent = 0
        .CharacterUnitRightIndent = 0
        .CharacterUnitFirstLineIndent = 0
        .LineUnitBefore = 0
        .LineUnitAfter = 0
        .MirrorIndents = False
        .TextboxTightWrap = wdTightNone
        .CollapsedByDefault = False
        .ReadingOrder = wdReadingOrderRtl
    End With
    ActiveDocument.Styles("מילת פתיח עיצוב מהיר"). _
        NoSpaceBetweenParagraphsOfSameStyle = False
    ActiveDocument.Styles("מילת פתיח עיצוב מהיר").ParagraphFormat.TabStops. _
        ClearAll
    With ActiveDocument.Styles("מילת פתיח עיצוב מהיר").ParagraphFormat
        With .Shading
            .Texture = wdTextureNone
            .ForegroundPatternColor = wdColorAutomatic
            .BackgroundPatternColor = wdColorAutomatic
        End With
        .Borders(wdBorderLeft).LineStyle = wdLineStyleNone
        .Borders(wdBorderRight).LineStyle = wdLineStyleNone
        .Borders(wdBorderTop).LineStyle = wdLineStyleNone
        .Borders(wdBorderBottom).LineStyle = wdLineStyleNone
        With .Borders
            .DistanceFromTop = 1
            .DistanceFromLeft = 4
            .DistanceFromBottom = 1
            .DistanceFromRight = 4
            .Shadow = False
        End With
    End With
    With ActiveDocument.Styles("מילת פתיח עיצוב מהיר").Frame
        .TextWrap = True
        .WidthRule = wdFrameAuto
        .HeightRule = wdFrameAuto
        .HorizontalPosition = wdFrameRight
        .RelativeHorizontalPosition = wdRelativeHorizontalPositionColumn
        .VerticalPosition = CentimetersToPoints(0)
        .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
        .HorizontalDistanceFromText = CentimetersToPoints(0.13)
        .VerticalDistanceFromText = CentimetersToPoints(0)
        .LockAnchor = False
    End With
On Error GoTo 0
    
'חלק ב החלת העיצוב
    
'החלת עיצוב שורה אחרונה
    
'שינוי הטאבים ל- 0
    Selection.ParagraphFormat.TabStops.ClearAll
    ActiveDocument.DefaultTabStop = CentimetersToPoints(0)

'הוספת טאב בסוף כל פיסקה
    Selection.WholeStory
    Selection.ParagraphFormat.Alignment = wdAlignParagraphDistribute
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^p"
        .Replacement.Text = "^t^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    
    Selection.Find.Execute Replace:=wdReplaceAll
    
'החלת עיצוב חלון ועיצוב מילה ראשונה

'החלת סימן החרגה עבור פיסקאות מודגשות (כותרות)
Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = ""
        .Replacement.Text = "^s^s^s^s^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .Font.BoldBi = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = False
    End With
    
    Selection.Find.Execute Replace:=wdReplaceAll
    
'סימון המילה הראושנה והפרדתו מהפיסקה שאחריו (כדי שהסגנון יחול רק עליו ולא על כל הפיסקה
'אין אפשרות שיחול רק עליו בלי זה כי צריך להחיל עליו מסגרת
'אין בעיה במה שהואנפרד כי המסגרת מוגדרת לקבץ אותו יחד עם הפיסקה שאחריו
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "(^13)([!^s]@ )"
        .Replacement.Text = "\1^+^=^~^s\2^s^~^=^+^p"
        .Forward = True
        .Wrap = wdFindContinue
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
'החלת סגנון מילה ראשונה כולל מסגרת
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Application.ScreenRefresh
    Selection.Find.Replacement.style = ActiveDocument.Styles("מילת פתיח עיצוב מהיר")
   
    With Selection.Find
        .Text = "(^+^=^~^s)(*)(^s^~^=^+)"
        .Replacement.Text = "\2"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
    
'ניקוי הסימנים מפסקאות מודגשות (כותרות)
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "^s^s^s^s"
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = False
        .MatchCase = False
        .MatchWholeWord = False
        .MatchKashida = False
        .MatchDiacritics = False
        .MatchAlefHamza = False
        .MatchControl = False
        .MatchAllWordForms = False
        .MatchSoundsLike = False
        .MatchWildcards = True
    End With
    
    Selection.Find.Execute Replace:=wdReplaceAll
    
    
End Sub

[simcha33345]

@pcinfogmach

גירסה מס' 5:

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

עריכה:
זה התרגום של ההודעה:

[pcinfogmach]

@simcha33345
חששתי שזה יקרה היה בעיה דומה בגירסה 1 אנסה לעכן בגירסה הבאה בלי נדר.
אם תוכל לעשות לי טובה אחת לבדוק את המאקרו הזה אם הוא גם לא עובד.

[simcha33345]

@pcinfogmach אוקי, אני שולח לידיד ואחכה לתגובתו.
אעדכן כשיעדכן אותי בס"ד.

[דאנציג]

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

הפיתרון שלי הוא: להחריג כל פיסקה מודגשת.

לדעתי הפתרון הפשוט הוא להחריג את הפסקאות הממורכזות, ולאו דווקא מודגשות...

[בוקר טוב]

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

תודה. אנסה לטפל בזה בגירסאות הבאות בלי נדר.

אולי תעלה את המסמך בינתיים לכאן
לתועלת כולנו.