שיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות

NykUser

@צדיק-וטוב-לו-0 כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

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

Sub add_to_startup1()

Set fs = CreateObject("Scripting.FileSystemObject")
dirFile = Dir(Application.StartupPath & "\" & ActiveDocument.AttachedTemplate.Name)
If Len(dirFile) = 0 Then
    fs.CopyFile ActiveDocument.AttachedTemplate.FullName, Application.StartupPath & "\" & ActiveDocument.AttachedTemplate.Name
    If fs.FileExists(Application.StartupPath & "\" & ActiveDocument.AttachedTemplate) = True Then
        MsgBox ActiveDocument.AttachedTemplate & " Was Copied to Start up Path"
    Else
       A = InputBox("Please copy " & ActiveDocument.AttachedTemplate & " to this folder", "Error did not copy", Application.StartupPath)
    End If
Else
    MsgBox ActiveDocument.AttachedTemplate & " Already in Startup Path remove first and repeat"
    Call Shell("explorer.exe" & " " & Application.StartupPath, vbNormalFocus)
End If
End Sub

צדיק וטוב לו 0

@NykUser כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

@צדיק-וטוב-לו-0 כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

מצורף הקוד לזה, זה בודק האם כבר נמצא תבנית בשם זה, ובמידה שכן פתוח התקייה, כדי שיכולו למחקו אם רוצים, בעיקרון אפשר לשנות זאת שזה ימחק הישן ויעתיק החדש
Sub add_to_startup1()

Set fs = CreateObject("Scripting.FileSystemObject")
dirFile = Dir(Application.StartupPath & "\" & ActiveDocument.AttachedTemplate.Name)
If Len(dirFile) = 0 Then
    fs.CopyFile ActiveDocument.AttachedTemplate.FullName, Application.StartupPath & "\" & ActiveDocument.AttachedTemplate.Name
    If fs.FileExists(Application.StartupPath & "\" & ActiveDocument.AttachedTemplate) = True Then
        MsgBox ActiveDocument.AttachedTemplate & " Was Copied to Start up Path"
    Else
       A = InputBox("Please copy " & ActiveDocument.AttachedTemplate & " to this folder", "Error did not copy", Application.StartupPath)
    End If
Else
    MsgBox ActiveDocument.AttachedTemplate & " Already in Startup Path remove first and repeat"
    Call Shell("explorer.exe" & " " & Application.StartupPath, vbNormalFocus)
End If
End Sub

איזה צירוף מקשים יגרום להפעלת המאקרו?

או שכשאני מצרף תבנית אני צריך להחליט?

דאנציג

@צדיק-וטוב-לו-0 כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

או שכשאני מצרף תבנית אני צריך להחליט!

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

ולי לא מותקן וינראר, ולכן אני לא עושה זאת...

צדיק וטוב לו 0

@דאנציג כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

@צדיק-וטוב-לו-0 כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

או שכשאני מצרף תבנית אני צריך להחליט!

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

ולי לא מותקן וינראר, ולכן אני לא עושה זאת...

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

מניין

@pcinfogmach לגבי המאקרו הזה [תבנית מחיקת פסקאות ריקות ורווח לפני פסקא], יש לשים לב, שבתחילת פסקא או אחר מעבר מקטע זה לא מוחק פסקאות ריקות, בגלל שהמאקרו מחפש סוף פסקא כפול, ולא תחילת פיסקא כפול, אשמח מאוד לקבל רעיונות ממי שיש לו פיתרון לזה.

mfmf

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

מניין

@mfmf הכי טוב זה להכניס את הכל מיד בהקלדה, אם יש לך כבר קובץ מוכן אפשר להחליף באופן אוטומטי דרך המאקרו הזה, ובמקום ממ תכתוב סימן.

ישראל כהן

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

אין בעיה בנתיב אולי תעלה לכאן תמונת מסך של השגיאה? תוודא שוב בבקשה שהעתקת את הנתיב במלואו.
ייתכן שאתה צריך לאשר גישה לתיקייה זו תבדוק אם יש לך גישה אליה בדרך זו C:\Users\username\AppData\Roaming\Microsoft\Word\STARTUP
יש להחליף את - username בשם המשתמש שלכם במחשב

לי גם מופיעה הודעת שגיאה, כמו ל @ב-מ-ב-ל-יק
ובדרך שאתה כתבת, אין לי בכלל תיקיה בשם STARTUP בתוך התיקיה WORD, [אלא רק קבצי וורד שנשמרו אוטומטית]
אשמח אם תוכל לעזור לי. תודה רבה.

מניין

@מניין כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

@pcinfogmach לגבי המאקרו הזה [תבנית מחיקת פסקאות ריקות ורווח לפני פסקא], יש לשים לב, שבתחילת פסקא או אחר מעבר מקטע זה לא מוחק פסקאות ריקות, בגלל שהמאקרו מחפש סוף פסקא כפול, ולא תחילת פיסקא כפול, אשמח מאוד לקבל רעיונות ממי שיש לו פיתרון לזה.

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

pcinfogmach

שאלה לגבי מאקרו עיצוב ספרי קודש

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

צדיק וטוב לו 0

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

שאלה לגבי מאקרו עיצוב ספרי קודש

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

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

כמו"כ לגבי המאקרו למרכוז שורה אחרונה כרגע עושה גם בפיסקה עם שני שורות האם עדיף שיעקוף על פיסקאות כאלו?

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

דאנציג

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

שאלה לגבי מאקרו עיצוב ספרי קודש

גם אני מצטרף ל @צדיק-וטוב-לו-0

מניין

@דאנציג כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

שאלה לגבי מאקרו עיצוב ספרי קודש

גם אני מצטרף ל @צדיק-וטוב-לו-0

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

mfmf

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

שאלה לגבי מאקרו עיצוב ספרי קודש

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

כמו"כ לגבי המאקרו למרכוז שורה אחרונה כרגע עושה גם בפיסקה עם שני שורות האם עדיף שיעקוף על פיסקאות כאלו?

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

pcinfogmach

@mfmf
@mfmf כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

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

מניין

@צדיק-וטוב-לו-0

תגובה למה שכתבת כאן

כמדומני שהוא מוגבל בעברית קצת, לא?
[מהאות שצג הוא משתגע]

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

mfmf

@pcinfogmach כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

@mfmf
@mfmf כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

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

יצרת את זה? ראיתי את זה בתוסף בגירסה של האדם החושב.
אתה יכול לתת לי את הקוד?

pcinfogmach

@mfmf
הנה הקוד עבור הוספת חלון במסמך
הקוד בבסיס הוא של @NykUser אני רק שיפצתי אותו
אשמח מאוד אם תוכל לבדוק לי שהכל עובד כשורה
שם המאקרו להוספת חלון כפול הוא: DoubleWindowUnderFirstWordSelection
כמו"כ נוסף כאן אפשרות להרחיב את החלון לכמה מילים לפי בחירה במאקרו WindowUnderManyWordsSelection

Option Explicit

Sub WindowUnderFirstWordSelection()
'
'הוספת חלון מתחת למילה הראשונה בפיסקאות שנבחרו
'מאת ניקיוזר
'
 
'הצהרת המשתנים
    Dim myrange As Range
    Dim i As Integer
    Dim para As Range
    Dim char As Range
    Dim replacements As Boolean
    
'בחירת טווח הלולאה
    Set myrange = Selection.Range
    
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    myrange.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    
    'מניעת בעיות כלליות
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
        Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With myrange.Find
        .Execute FindText:=Chr(11) & vbTab, ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
            If .Found = True Then
                replacements = True
              End If
        .Execute FindText:=Chr(11) & ChrW(8197), ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    End With
        
'תחילת הלולאה
    For i = 1 To myrange.Paragraphs.count
    Set para = myrange.Paragraphs(i).Range 'טווח הפיסקאות
    
' החרגות
    If para.ComputeStatistics(wdStatisticLines) <> 1 Then
    If para.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then
    If Not para.Style Like "כותרת*" Then
    If Not para.Style Like "Heading*" Then
    
    'If Not para.ComputeStatistics(wdStatisticLines) <> 2 Then replacements = False
     
'שלב א העמדת הסמן אחרי הרווח הראשון בפיסקה
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
            .Select
      End With
    
'שלב ב הוספת החלון
        With Selection
            .EndKey Unit:=wdLine
              If .Text = Chr(13) Then GoTo nxt
                If .Text = Chr(11) Then .Delete Unit:=wdCharacter, count:=1 'מניעת בעיות
                    .TypeText Text:=Chr(11) & ChrW(8197)
                        Set char = Selection.Range
                            .Previous.Font.Spacing = char.Information(wdHorizontalPositionRelativeToTextBoundary) - para.Information(wdHorizontalPositionRelativeToTextBoundary)

          End With
        
'המשך של מניעת בעיות כלליות
    If replacements = True Then
    With para
        .Collapse: .MoveUntil Chr(13): .MoveEnd: .Collapse Direction:=wdCollapseEnd
        .End = .End - 1 ' subtract 1 from the end position
        .Select
     End With
     Selection.HomeKey Unit:=wdLine
    
    'מניעת בעיות
    With Selection
      If .Text = ChrW(8197) Then GoTo nxt
        If .Previous.Text = Chr(11) Then .Previous.Delete Unit:=wdCharacter, count:=1
        End With
        
'הוספת טאב ידני
    Dim middlePosition As Double
        middlePosition = Selection.Sections(1).PageSetup.TextColumns(1).Width / 2
    With Selection
        .ParagraphFormat.TabStops.ClearAll
            .ParagraphFormat.TabStops.Add Position:=middlePosition, Alignment:=wdAlignTabCenter
        End With

    Selection.TypeText Chr(11) & vbTab
        
'המשך של החרגות
    End If
    End If
    End If
    End If
    End If
    
'המשך הלולאה
nxt:
Next
Application.ScreenRefresh
End Sub

Sub DoubleWindowUnderFirstWordSelection()
'
'הוספת חלון מתחת למילה הראשונה בפיסקאות שנבחרו
'מאת ניקיוזר
'
 
'הצהרת המשתנים
    Dim myrange As Range
    Dim i As Integer
    Dim para As Range
    Dim char As Range
    Dim replacements As Boolean
    Dim solveletters As VbMsgBoxResult
        
'בחירת טווח הלולאה
    Set myrange = Selection.Range
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    myrange.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
        
'תחילת הלולאה
    For i = 1 To myrange.Paragraphs.count
    Set para = myrange.Paragraphs(i).Range 'טווח הפיסקאות
    
' החרגות
    If Not para.ComputeStatistics(wdStatisticLines) <> 3 Then
    If para.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then
    If Not para.Style Like "כותרת*" Then
    If Not para.Style Like "Heading*" Then
    
'מניעת בעיות כלליות
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With para.Find
        .Execute FindText:=Chr(11) & vbTab, ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
            If .Found = True Then
                replacements = True
              End If
        .Execute FindText:=Chr(11) & ChrW(8197), ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    End With
    
     
'שלב א העמדת הסמן אחרי הרווח הראשון בפיסקה
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
            If .Previous(count:=2) = Chr(93) Or .Previous(count:=2) = Chr(41) Then 'מניעת בעיות
              If solveletters = vbNo Then GoTo skp
               If solveletters = vbYes Then GoTo doit
                  solveletters = MsgBox("ייתכן שהמילה הראשונה משמשת כסימון של סימנים. האם להרחיב את החלון עד מתחת למילה השנייה?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה")
                    If solveletters = vbNo Then GoTo skp
doit:
                    If solveletters Then .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
               End If 'עד כאן מניעת בעיות
skp:
        .Select
      End With
    
'שלב ב הוספת החלון
        With Selection
            .EndKey Unit:=wdLine
                If .Text = Chr(11) Then .Delete Unit:=wdCharacter, count:=1 'מניעת בעיות
                    .TypeText Text:=Chr(11) & ChrW(8197)
                        Set char = Selection.Range
                            .Previous.Font.Spacing = char.Information(wdHorizontalPositionRelativeToTextBoundary) - para.Information(wdHorizontalPositionRelativeToTextBoundary)
          End With
          
'מניעת יצירת חלון כפול בפסקה עם 4 שורות
        Dim rng4 As Range
        Dim para4 As Range
        Set rng4 = Selection.Range
        Set para4 = rng4.Paragraphs(1).Range
        
        If Not para4.ComputeStatistics(wdStatisticLines) <> 4 Then
        If replacements = True Then Call LastLine.CenterLastLineSelection
        replacements = False
        GoTo endr
        End If
          
'שלב ג הוספת חלון בשורה שלישית
          With Selection
            .EndKey Unit:=wdLine
                If .Text = Chr(11) Then .Delete Unit:=wdCharacter, count:=1 'מניעת בעיות
                    .TypeText Text:=Chr(11) & ChrW(8197)
                        Set char = Selection.Range
                            .Previous.Font.Spacing = char.Information(wdHorizontalPositionRelativeToTextBoundary) - para.Information(wdHorizontalPositionRelativeToTextBoundary)
          End With
        
'מניעת יצירת פיסקה עם 4 שורות
        If Not para4.ComputeStatistics(wdStatisticLines) <> 4 Then
        Selection.Previous.Delete Unit:=wdCharacter, count:=2
        If replacements = True Then Call LastLine.CenterLastLineSelection
        replacements = False
        End If
        
endr:
        
'המשך של החרגות
    End If
    End If
    End If
    End If
'המשך הלולאה
Next
Application.ScreenRefresh
End Sub

Sub WindowUnderFirstWordWholeDoc()
'
'הוספת חלון מתחת למילה הראשונה בכל המסמך
'מאת ניקיוזר
'
 
'הצהרת המשתנים
    Dim myrange As Range
    Dim mrange As Range
    Dim i As Integer
    Dim para As Range
    Dim char As Range
    Dim replacements As Boolean
    Dim solveletters As VbMsgBoxResult
    
'סיווג פיסקאות
    Dim exclude2Lines As Boolean
    Dim exclude3Lines As Boolean
    Dim doublewindow As Boolean
    Dim replacemsg As Boolean
    
    exclude2Lines = MsgBox("האם ברצונך להוסיף חלון בפיסקאות עם 2 שורות?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה") = vbNo
    
    If exclude2Lines Then
    exclude3Lines = MsgBox("האם ברצונך להוסיף חלון בפיסקאות עם 3 שורות?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה") = vbNo
    End If
    
    If exclude3Lines Then GoTo nodouble
    doublewindow = MsgBox("האם ברצונך לעצב חלון כפול בפיסקאות עם שלוש שורות?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה") = vbYes
    
nodouble:
        
'בחירת טווח הלולאה
    Selection.WholeStory
    Set myrange = Selection.Range
    Set mrange = Selection.Range
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
    mrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'מניעת בעיות עם סימוני הערות שוליים
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    mrange.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    mrange.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    mrange.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
        
'מניעת בעיות עם חלונות קודמים
    mrange.Find.Execute FindText:=vbVerticalTab & " ", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll

'מניעת בעיות עם שורה אחרונה
    With mrange.Find
        .Execute FindText:=Chr(11) & vbTab
            If .Found = True Then
              replacemsg = MsgBox("כדי למנוע בעיות מומלץ להסיר את עיצוב מירכוז שורה אחרונה. האם להסיר מירכוז שורה אחרונה כעת?", _
                vbExclamation + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה") = vbYes
                    If replacemsg Then
                      .Execute FindText:=Chr(11) & vbTab, ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
                        replacements = True
              End If
                End If
    
    End With
    
Application.ScreenRefresh
    
'תחילת הלולאה
    For i = 1 To myrange.Paragraphs.count
    Set para = myrange.Paragraphs(i).Range 'טווח הפיסקאות
    
' החרגות
    If Not para.ComputeStatistics(wdStatisticLines) <> 1 Then GoTo nxt
    If Not para.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then GoTo nxt
    If para.Style Like "כותרת*" Then GoTo nxt
    If para.Style Like "Heading*" Then GoTo nxt
    If Not para.ComputeStatistics(wdStatisticLines) <> 2 And exclude2Lines Then GoTo nxt
    If Not para.ComputeStatistics(wdStatisticLines) <> 3 And exclude3Lines Then GoTo nxt
    If Not para.ComputeStatistics(wdStatisticLines) <> 3 And doublewindow Then GoTo nxt

    
    'If Not para.ComputeStatistics(wdStatisticLines) <> 2 Then replacements = False
     
'שלב א העמדת הסמן אחרי הרווח הראשון בפיסקה
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
            If .Previous(count:=2) = Chr(93) Or .Previous(count:=2) = Chr(41) Then 'מניעת בעיות
              If solveletters = vbNo Then GoTo skp
               If solveletters = vbYes Then GoTo doit
                  solveletters = MsgBox("ייתכן שהמילה הראשונה משמשת כסימון של סימנים. האם להרחיב את החלון עד מתחת למילה השנייה?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה")
                    If solveletters = vbNo Then GoTo skp
doit:
                    If solveletters Then .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
               End If 'עד כאן מניעת בעיות
skp:
        .Select
      End With
    
'שלב ב הוספת החלון
        With Selection
            .EndKey Unit:=wdLine
              If .Text = Chr(13) Then GoTo nxt
                If .Text = Chr(11) Then .Delete Unit:=wdCharacter, count:=1 'מניעת בעיות
                    .TypeText Text:=Chr(11) & ChrW(8197)
                        Set char = Selection.Range
                            .Previous.Font.Spacing = char.Information(wdHorizontalPositionRelativeToTextBoundary) - para.Information(wdHorizontalPositionRelativeToTextBoundary)

          End With
    
    
'המשך הלולאה
nxt:
Next

Application.ScreenRefresh

'המשך של מניעת בעיות כלליות
    If replacements = True Then
        Dim rtrnlstln As Boolean
            rtrnlstln = MsgBox("האם להחזיר עיצוב שורה אחרונה כעת?", vbQuestion + vbYesNo + vbMsgBoxRight + vbMsgBoxRtlReading, "מאקרו חלון מתחת למילה הראשונה") = vbYes
               If rtrnlstln Then Call LastLine.CenterLastLineWholeDoc
      End If
        
      
If doublewindow Then
    Selection.WholeStory
        Call DoubleWindowUnderFirstWordSelection
  End If

End Sub

Sub RemoveWindowUnderFirstWordSelected()

Dim myrange As Range
Set myrange = Selection.Range
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
    myrange.Find.Execute FindText:=vbVerticalTab & " ", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
Application.ScreenRefresh
End Sub

Sub RemoveWindowUnderFirstWordWholeDoc()

Dim myrange As Range
Selection.WholeStory
Set myrange = Selection.Range
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
myrange.Find.Execute FindText:=vbVerticalTab & " ", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll

Application.ScreenRefresh
End Sub

Sub WindowUnderManyWordsSelection()
'
'הוספת חלון מתחת למילה הראשונה בפיסקאות שנבחרו
'מאת ניקיוזר
'
 
'הצהרת המשתנים
    Dim myrange As Range
    Dim i As Integer
    Dim para As Range
    Dim char As Range
    Dim replacements As Boolean
    Dim iterations As Integer
    Dim x As Integer
    
'בחירת טווח הלולאה
    Set myrange = Selection.Range
    
    On Error Resume Next
    iterations = InputBox("כתבו במספרים מתחת לכמה מילים תרצו להחיל את החלון")
    On Error GoTo 0
    
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    myrange.Find.Execute FindText:="^f", ReplaceWith:="^&%?!#...", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#... ", ReplaceWith:=ChrW(8194), Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    myrange.Find.Execute FindText:="%?!#...", ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    
    'מניעת בעיות כלליות
    myrange.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
        Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With myrange.Find
        .Execute FindText:=Chr(11) & vbTab, ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
            If .Found = True Then
                replacements = True
              End If
        .Execute FindText:=Chr(11) & ChrW(8197), ReplaceWith:="", Forward:=True, Wrap:=wdFindStop, Replace:=wdReplaceAll
    End With
        
'תחילת הלולאה
    For i = 1 To myrange.Paragraphs.count
    Set para = myrange.Paragraphs(i).Range 'טווח הפיסקאות
    
' החרגות
    If para.ComputeStatistics(wdStatisticLines) <> 1 Then
    If para.ParagraphFormat.Alignment <> wdAlignParagraphCenter Then
    If Not para.Style Like "כותרת*" Then
    If Not para.Style Like "Heading*" Then
    
    'If Not para.ComputeStatistics(wdStatisticLines) <> 2 Then replacements = False
     
'שלב א העמדת הסמן אחרי הרווח הראשון בפיסקה
 For x = 1 To iterations
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
            .Select
      End With
      Next x
    
'שלב ב הוספת החלון
        With Selection
            .EndKey Unit:=wdLine
              If .Text = Chr(13) Then GoTo nxt
                If .Text = Chr(11) Then .Delete Unit:=wdCharacter, count:=1 'מניעת בעיות
                    .TypeText Text:=Chr(11) & ChrW(8197)
                        Set char = Selection.Range
                            .Previous.Font.Spacing = char.Information(wdHorizontalPositionRelativeToTextBoundary) - para.Information(wdHorizontalPositionRelativeToTextBoundary)

          End With
        
'המשך של מניעת בעיות כלליות
    If replacements = True Then
    With para
        .Collapse: .MoveUntil Chr(13): .MoveEnd: .Collapse Direction:=wdCollapseEnd
        .End = .End - 1 ' subtract 1 from the end position
        .Select
     End With
     Selection.HomeKey Unit:=wdLine
    
    'מניעת בעיות
    With Selection
      If .Text = ChrW(8197) Then GoTo nxt
        If .Previous.Text = Chr(11) Then .Previous.Delete Unit:=wdCharacter, count:=1
        End With
        
'הוספת טאב ידני
    Dim middlePosition As Double
        middlePosition = Selection.Sections(1).PageSetup.TextColumns(1).Width / 2
    With Selection
        .ParagraphFormat.TabStops.ClearAll
            .ParagraphFormat.TabStops.Add Position:=middlePosition, Alignment:=wdAlignTabCenter
        End With

    Selection.TypeText Chr(11) & vbTab
        
'המשך של החרגות
    End If
    End If
    End If
    End If
    End If
    
'המשך הלולאה
nxt:
Next
Application.ScreenRefresh
End Sub

דאנציג

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

pcinfogmach

@דאנציג כתב בשיתוף | תגובות ל - אוסף מאקרו לוורד - אינדקס מאקרו שימושי + הוראות חשובות:

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

לא התעמקתי מדי אבל לכאורה

יש להגדיר טווח לפני שורת הקוד

start:

כך:

Dim slctdRange as Range
set slctdRange = Selection.Range
start:

ובהמשך הקוד במקום

	With Selection.Find

לעשות

with slctdRange.find
.Wrap = wdFindStop

ושאר המאקרו כרגיל

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