שיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....

[pcinfogmach]

@pcinfogmach

קוד להוספת צורה במיקום הנוכחי במסמך -

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

msoShapeRectangle זהו שם הצורה = ריבוע.
לרשימה של כל הצורות עיין כאן

Sub הוספת_צורה_במיקום_הנוכחי_במסמך()

'יצירת משתנים
Dim sel As Range
Dim topDist As Integer, leftDist As Integer
 Dim sq As Shape

    'חישוב המיקום הנוכחי של סמן העכבר
    Set sel = Selection.Range
    topDist = sel.Information(wdVerticalPositionRelativeToPage)
    leftDist = sel.Information(wdHorizontalPositionRelativeToPage)
    

'הוספת ריבוע המספרים הם הגובה והרוחב של הצורה כמובן שאפשר לשנות אותם
Set sq = doc.Shapes.AddShape(msoShapeRectangle, leftDist, topDist, 10, 10)

End Sub

אפשר גם להחיל הגדרות עבור הצורה

לדוגמא היישור של הצורה לפני או מאחרי הטקסט או בשורה עם הטקסט וכו' עיין כאן לרשימה המלאה
דוגמא: sq.WrapFormat.Type = wdWrapInline

פקודות אלו יהפכו את הצורה ואת המילוי שלהלשקופים:
sq.Line.Visible = msoFalse
sq.Fill.Visible = msoFalse

פקודות אלו מגדירים את המרווח בין הצורה לטקסט:
sq.WrapFormat.DistanceTop = 0
sq.WrapFormat.DistanceBottom = 0
sq.WrapFormat.DistanceLeft = 0
sq.WrapFormat.DistanceRight = 0

פקודות אלו מגדירים את הצורה להתאים אוטומטית לתוכן הטקסט שבפנים"
sq.TextFrame.AutoSize = True sq.TextFrame.WordWrap = False sq.TextFrame.TextRange.ParagraphFormat.SpaceAfter = 0

[pcinfogmach]

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

'להוסיף לפני תחילת המאקרו
Application.ScreenUpdating = False
'ואחרי סוף המאקרו
Application.ScreenUpdating = true

[pcinfogmach]

@pcinfogmach
קוד להתקנת תבנית בתוך תיקיית ההתחלה של וורד
קרדיט ל - @NykUser

אפשר גם להקצות למאקרו קיצור מקשים כמו שמופיע בספויילר

Spoiler

התקנה_אל_תיקיית_startup()
    Dim fs As Object
    Dim dirFile As String
    Set fs = CreateObject("Scripting.FileSystemObject")
    dirFile = Dir(Application.StartupPath & "\" & "Cross referece" & "*" & ".dot")
    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
        Else
            Dim A As String
            A = InputBox("העתק את " & ActiveDocument.AttachedTemplate & " לנתיב זה", "שגיאה בהתקנה", Application.StartupPath)
        End If
    Else
        MsgBox ActiveDocument.AttachedTemplate & " הקובץ כבר נמצא בתיקיית ההתקנה יש להסירו לפני התקנה חוזרת"
        Call Shell("explorer.exe" & " " & Application.StartupPath, vbNormalFocus)
    End If
End Sub

[pcinfogmach]

קוד ליצירת לולאה - עד מילוי תנאי מסויים

Do
'הכנס פקודה
Loop Until 'הכנס כאן תנאי להפסקת הלולאה

דוגמא שימושית: קוד להזזת הסמן עד שהטקסט כבר אינו טקסט עילי

Do
Selection.Move Unit:=wdCharacter, Count:=1
Loop Until Selection.Font.Superscript = False

[pcinfogmach]

קוד להוספת סגנון והסרתו

'הוספת והסרת הסגנון
    Dim styl As style
    
    On Error Resume Next
    Set styl = ActiveDocument.Styles("הסגנון שלי")
    On Error GoTo 0
    
    If styl Is Nothing Then
'יצירת הסגנון
      ActiveDocument.Styles.Add Name:="הסגנון שלי", _
                          Type:=WdStyleType.wdStyleTypeCharacter
'קביעת מיקום הסגנון בסרגל הסגנונות (מס' 3 - ניתן לשינוי)
       ActiveDocument.Styles("הסגנון שלי").Priority = 3
'הוספת הסגנון לסרגל הסגנונות
        ActiveDocument.Styles("הסגנון שלי").QuickStyle = True

    Else
        styl.Delete
    End If
                          
'קוד לההחלת הסגנון על הטקסט המוסמן
Selection.Range.style = "הסגנון שלי"

[pcinfogmach]

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

Dim i As Integer
For i = 1 To 3
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
        .Select
    End With
Next i

אפשר גם לתת למשתמש לבחור כמה פעמים תחזור הלולאה על עצמה

Dim iterations As Integer
    
On Error Resume Next
iterations = InputBox("כתבו במספרים כמה פעמים לחזור על הפקודה")
On Error GoTo 0

For i = 1 To iterations
    With para
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
        .Select
    End With
Next i

[pcinfogmach]

לפעמים נוצר צורך שהמאקרו יתעלם משגיאות (לדוגמא: אם נותנים למשתמש להזין משהו והוא לא מזין כלום זה יוצר שגיאה)

לפני השורה הבעייתית יש להזין

On Error Resume Next

ולאחריה (כדי שלא ישאר פקד השגיאות כבוי)

On Error GoTo 0

[pcinfogmach]

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

Dim interaction As VbMsgBoxResult
interaction = MsgBox("הזן כאן הוראות למשתמש", vbQuestion + vbYesNoCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "הזן כאן כותרת")

Select Case interaction
    Case vbCancel
        ' המשתמש לחץ על ביטול
        MsgBox "הפעולה בוטלה"
exit sub

    Case vbYes
        ' המשתמש לחץ על כן
        'הכניסו איזשהו קוד כאן

    Case vbNo
        ' המשתמש לחץ על לא
        'הכניסו איזשהו קוד כאן
End Select

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

Dim interaction As VbMsgBoxResult
interaction = MsgBox("הזן כאן הוראות למשתמש", vbQuestion + vbYesNoCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "הזן כאן כותרת")

if interaction = vbCancel then
 ' המשתמש לחץ על ביטול
"הפעולה בוטלה" msgbox
exit sub
end if

if interaction = vbYes then
 ' המשתמש לחץ על כן
'הכניסו איזשהו קוד כאן
end if

if interaction = vbNo then
 ' המשתמש לחץ על לא
'הכניסו איזשהו קוד כאן
end if

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

If Dialogs(wdDialogFormatFont).Show = False Then Exit Sub

עדכון:
כדי להראות למשתמש הודעה במשך הרצת המאקרו

Application.StatusBar = "ההודעה שלי"

אפשר להפסיק את הצגת ההודעה על ידי הכנסתו ללואה

[pcinfogmach]

איך לשנות את תחום הטקסט המסומן

'הקטנת תחום הטקסט המוסמן ב -1 מהסוף
Selection.MoveEnd wdCharacter, -1
'או
With Selection.Range
.End = .End - 1
   .Select
   End With

'הגדלת תחום הטקסט המוסמן ב -1 מהסוף
Selection.MoveEnd wdCharacter, 1
'או
With Selection.Range
.End = .End + 1
   .Select
   End With

'הקטנת תחום הטקסט המוסמן ב -1 מההתחלה
Selection.Movestart wdCharacter, 1
'או
With Selection.Range
.Start = .Start + 1
   .Select
   End With

'הגדלת תחום הטקסט המוסמן ב -1 מההתחלה
Selection.MoveEnd wdCharacter, -1
'או
With Selection.Range
.Start = .Start - 1
   .Select
   End With

'העברת הסמן לפני הטקסט המסומן
Selection.Collapse Direction:=wdCollapseStart

'העברת הסמן אחרי הטקסט המסומן
  Selection.Collapse Direction:=wdCollapseend

[pcinfogmach]

קוד לפתיחת מסמך קובץ תיקייה או אתר אינטרנט

רק צריך לוודא שהוא יהיה במודול בפני עצמו כדי למנוע בעיות ושלא יהיה מופע כפול של option Explicit

Option Explicit

Private Declare PtrSafe Function ShellExecute Lib "shell32.dll" Alias "ShellExecuteA" _
(ByVal hwnd As LongPtr, ByVal lpOperation As String, ByVal lpFile As String, _
ByVal lpParameters As String, ByVal lpDirectory As String, ByVal nShowCmd As Long) As LongPtr

Sub OpenWebPage()
    Dim url As String
    url = "הכנס כאן את כתובת האתר תיקייה או הקובץ באופן מלא" 'Replace with the URL of the webpage you want to open
    ShellExecute 0, "open", url, vbNullString, vbNullString, vbNormalFocus
End Sub

[pcinfogmach]

קוד עיצוב פיסקה כנהוג בספרי קודש - מילה ראשונה, חלון, ומירכוז שורה אחרונה:
קרדיט ל- @NykUser @מאקרו ו-@pcinfogmach

מצו"ב שני שיטות:

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

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

---

שיטה ראשונה:
חלון.bas
שורה_אחרונה.bas

Sub עיצוב_מילה_ראשונה_לפי_סגנון()

   Dim myDialog As Dialog, para As Paragraph, rng As Range, styl As String
   
    styl = ActiveDocument.Styles(wdStyleStrong).NameLocal
    Set rng = Selection.Range
    Set myDialog = Dialogs(wdDialogFormatStyle)
    
    
    Selection.MoveUp Unit:=wdParagraph, Count:=1
    
    With myDialog
        .Name = styl
        .Display
        End With
              
   For Each para In rng.Paragraphs
    With para.Range
    .End = .Start
    .MoveEndUntil " ", wdForward
    .Select
    End With
    myDialog.Execute
    Next para
    
End Sub

Sub עיצוב_מילה_ראשונה_ללא_סגנון()

   Dim myDialog As Dialog, para As Paragraph, rng As Range
   
    Set rng = Selection.Range
    Set myDialog = Dialogs(wdDialogFormatFont)
    
    myDialog.Display
           
   For Each para In rng.Paragraphs
    With para.Range
    .End = .Start
    .MoveEndUntil " ", wdForward
    .Select
    End With
    myDialog.Execute
    Next para
    
End Sub

Sub הסר_עיצוב_מילה_ראשונה()

   Dim para As Paragraph, rng, mrng As Range
           
   Set rng = Selection.Range
   
   For Each para In rng.Paragraphs
     
    With para.Range
        .Collapse: .MoveUntil cset:=" ": .MoveEnd: .Collapse Direction:=wdCollapseEnd
        .move Unit:=wdCharacter, Count:=1
        .Select
    End With
      
    Selection.CopyFormat
    Selection.MoveUp Unit:=wdParagraph, Count:=1, Extend:=wdExtend
    Selection.PasteFormat
    Application.ScreenRefresh
    Next para
    
End Sub

---

שיטה שניה:

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


Private Sub עיצוב_מהיר_כל_העיצובים()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

slctd.Select

'הוסף סימנים ומרכז שורה אחרונה
Call part1(slctd)

'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה
    slctd.InsertBefore "$$$$$$$$$" & Chr(13)

'הכנות בשביל עיצוב מילה ראשונה או חלון
Call part2(slctd)
'יצירת הסגנונות אם צריך
Call part3A
Call part3B
'החלת סגנון חלון
Call part4A
'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות
Call part4c
'ניקוי שאריות
Call part5
'msgbox תיקון הסטייה

End Sub
Private Sub עיצוב_מהיר_שורה_אחרונה_ומילה_ראשונה_בלי_חלון()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'הוסף סימנים ומרכז שורה אחרונה
Call part1(slctd)

'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה
    slctd.InsertBefore "$$$$$$$$$" & Chr(13)

'הכנות בשביל עיצוב מילה ראשונה או חלון
Call part2(slctd)

'יצירת הסגנונות אם צריך
Call part3B

'החלת סגנון מילה ראשונה
Call part4B

'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות
Call part4c

'ניקוי שאריות
Call part5

End Sub

Private Sub עיצוב_מהיר_הסר_את_כל_העיצובים()

Call part6
Call הסר_מרכוז_שורה_אחרונה

End Sub

Private Sub עיצוב_מהיר_מילה_ראשונה_עם_חלון()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'הוסף סימנים
Call part1B(slctd)

'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה
    slctd.InsertBefore "$$$$$$$$$" & Chr(13)


'הכנות בשביל עיצוב מילה ראשונה או חלון
Call part2(slctd)
'יצירת הסגנונות אם צריך
Call part3A
Call part3B
'החלת סגנון חלון
Call part4A
'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות
Call part4c
'ניקוי שאריות
Call part5




End Sub
Private Sub עיצוב_מהיר_מילה_ראשונה_בלי_חלון()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'הוסף סימנים
Call part1B(slctd)

'הוסף מעבר שורה עם סימנים לפני פיסקה ראשונה
    slctd.InsertBefore "$$$$$$$$$" & Chr(13)

'הכנות בשביל עיצוב מילה ראשונה או חלון
Call part2(slctd)

'יצירת הסגנונות אם צריך
Call part3B

'החלת סגנון מילה ראשונה
Call part4B

'החלת סגנון בלי חלון עבור פסקאות עם פחות מארבע שורות
Call part4c

'ניקוי שאריות
Call part5

End Sub

Private Sub עיצוב_מהיר_מרכוז_שורה_אחרונה()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'הוסף סימנים ומרכז שורה אחרונה
Call part1(slctd)

Call part5
End Sub
Private Sub הסר_מילה_ראשונה_וחלון()

Call part6

End Sub
Private Sub הסר_מרכוז_שורה_אחרונה()

'קביעת הטווח
Dim slctd As Range
Set slctd = Selection.Range
slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End

'הוסף סימנים בפיסקאות שנבחרו
slctd.Find.Execute _
FindText:="(*)(^t)(^13)", _
ReplaceWith:="\1+++++++\3", _
Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, _
Replace:=wdReplaceAll

'חפש והחלף לפי סימנים
Selection.Find.ClearFormatting
Selection.Find.Replacement.ClearFormatting
    
    With Selection.Find.Replacement.ParagraphFormat
        .SpaceBeforeAuto = False
        .SpaceAfterAuto = False
        .Alignment = wdAlignParagraphJustify
    End With
    With Selection.Find
        .Text = "(*)(+++++++)(^13)"
        .Replacement.Text = "\1\3"
        .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
    
End Sub

Sub part1(slctd As Range) ' Do something with slctd here
'
'מרכוז שורה אחרונה
'

    'שינוי הטאבים ל- 0
    Selection.ParagraphFormat.TabStops.ClearAll
    ActiveDocument.DefaultTabStop = CentimetersToPoints(0)
    
'החלת עיצוב שורה אחרונה
    Dim p As Paragraph
    For Each p In slctd.Paragraphs
        ' Check if paragraph contains more than one line
        If Not p.Range.ComputeStatistics(wdStatisticLines) > 1 Then
                p.Range.InsertBefore "$#$#$#"
                    GoTo nxt
                End If
                
                p.Range.ParagraphFormat.Alignment = wdAlignParagraphDistribute
                        p.Range.Characters.Last.Previous = vbTab
               
        If Not p.Range.ComputeStatistics(wdStatisticLines) > 2 _
        Or Not p.Range.ComputeStatistics(wdStatisticLines) > 3 Then
            p.Range.InsertBefore "$#$#$#"
            End If
nxt:
            Next p
End Sub
Sub part1B(slctd As Range) ' Do something with slctd here
'
'מרכוז שורה אחרונה
'

    'שינוי הטאבים ל- 0
    Selection.ParagraphFormat.TabStops.ClearAll
    ActiveDocument.DefaultTabStop = CentimetersToPoints(0)
    
'החלת עיצוב שורה אחרונה
    Dim p As Paragraph
    For Each p In slctd.Paragraphs
        ' Check if paragraph contains more than one line
        If Not p.Range.ComputeStatistics(wdStatisticLines) > 1 _
        Or Not p.Range.ComputeStatistics(wdStatisticLines) > 2 _
        Or Not p.Range.ComputeStatistics(wdStatisticLines) > 3 Then
                p.Range.InsertBefore "$#$#$#"
                    
End If
            Next p
End Sub
            
Private Sub part2(slctd As Range)
'
'הכנות בשביל עיצוב מילה ראשונה או חלון
'

'להוסיף פתרון בעיות עם סימני הערות שוליים צריך
        
'החלת סימן החרגה עבור פיסקאות מודגשות (כותרות)
Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "*^13"
        .Replacement.Text = "$$$$$$$$$^&"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .Font.BoldBi = True
        .Font.Bold = 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
    
'סימון המילה הראושנה והפרדתו מהפיסקה שאחריו (כדי שהסגנון יחול רק עליו ולא על כל הפיסקה
'אין אפשרות שיחול רק עליו בלי זה כי צריך להחיל עליו מסגרת
'אין בעיה במה שהואנפרד כי המסגרת מוגדרת לקבץ אותו יחד עם הפיסקה שאחריו
    
    slctd.Find.Execute FindText:="(^13)([!$]@ )", ReplaceWith:="\1^+^+^+^+\2^+^+^+^+^p", Forward:=True, Wrap:=wdFindStop, MatchWildcards:=True, Replace:=wdReplaceAll

End Sub

Private Sub part3A()
Dim styl As Style

'
'יצירת סגנון מילה ראשונה עם חלון
'

        'הוזזת הסמן לתחילת הטווח כדי למנוע עיצוב המילים המסומנות
        Selection.Collapse Direction:=wdCollapseStart

'בדיקה אם הסגנון כבר קיים
        On Error Resume Next
        Set styl = ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר")
        On Error GoTo 0

'הודעה למשתמש
If Not styl Is Nothing Then Exit Sub
Dim strt As VbMsgBoxResult
strt = MsgBox("לפני שנחתחיל תצטרכו לבחור עיצוב נפרד עבור סגנון 'מילת פתיח עם חלון עיצוב מהיר'." & vbNewLine & "לאחר יצירת הסגנון תמיד תוכלו לשנותו על ידי לחיצה ימנית על הסגנון בסרגל הסגנונות." & vbNewLine & "כך או כך הלחצן יחיל את הסגנון המבוקש על המילה הראשונה שבכל פיסקה.", _
vbInformation + vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "יצירת והחלת סגנון 'מילה ראשונה בהערות שוליים'")
If strt = vbCancel Then Exit Sub

        'בחירת העיצוב
        Selection.Font.Name = Selection.Font.Name
            With Dialogs(wdDialogFormatFont)
                .Update
                .Font = Selection.Font.Name
                .FontNameBi = Selection.Font.Name
                If .Show = False Then Exit Sub
            End With
            
            'יצירת הסגנון
            ActiveDocument.Styles.Add Name:="מילת פתיח עם חלון עיצוב מהיר", Type:=WdStyleType.wdStyleTypeParagraph
            ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").Priority = 3
            ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").QuickStyle = True
            
        
            'הגדרת הסגנון כסגנון עם מסגרת
            With ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר").ParagraphFormat
                .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
                .RelativeVerticalPosition = wdRelativeVerticalPositionParagraph
                .HorizontalDistanceFromText = CentimetersToPoints(0.13)
                .VerticalDistanceFromText = CentimetersToPoints(0)
                .LockAnchor = False
            End With

End Sub

Private Sub part3B()
Dim styl As Style
'
'יצירת סגנון מילה ראשונה בלי חלון
'

        'הוזזת הסמן לתחילת הטווח כדי למנוע עיצוב המילים המסומנות
        Selection.Collapse Direction:=wdCollapseStart

'בדיקה אם הסגנון כבר קיים
        On Error Resume Next
        Set styl = ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר")
        On Error GoTo 0
    
'הודעה למשתמש
If Not styl Is Nothing Then Exit Sub
Dim strt As VbMsgBoxResult
strt = MsgBox("לפני שנחתחיל תצטרכו לבחור עיצוב נפרד עבור סגנון 'מילת פתיח בלי חלון עיצוב מהיר'." & vbNewLine & "לאחר יצירת הסגנון תמיד תוכלו לשנותו על ידי לחיצה ימנית על הסגנון בסרגל הסגנונות." & vbNewLine & "כך או כך הלחצן יחיל את הסגנון המבוקש על המילה הראשונה שבכל פיסקה.", _
vbInformation + vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading, "יצירת והחלת סגנון 'מילה ראשונה בהערות שוליים'")
If strt = vbCancel Then Exit Sub

        'בחירת העיצוב
        Selection.Font.Name = Selection.Font.Name
            With Dialogs(wdDialogFormatFont)
                .Update
                .Font = Selection.Font.Name
                .FontNameBi = Selection.Font.Name
                If .Show = False Then Exit Sub
            End With
            
            'יצירת הסגנון
            ActiveDocument.Styles.Add Name:="מילת פתיח בלי חלון עיצוב מהיר", Type:=WdStyleType.wdStyleTypeCharacter
            ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר").Priority = 3
            ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר").QuickStyle = True

End Sub

Private Sub part4A()
'
'החלת סגנון מילה ראשונה כולל מסגרת
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Application.ScreenRefresh
    Selection.Find.Replacement.Style = ActiveDocument.Styles("מילת פתיח עם חלון עיצוב מהיר")
   
    With Selection.Find
        .Text = "(^+^+^+^+)(*)(^+^+^+^+)"
        .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
End Sub

Private Sub part4B()
'
'החלת סגנון מילה ראשונה בלי מסגרת
'
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Application.ScreenRefresh
    Selection.Find.Replacement.Style = ActiveDocument.Styles("מילת פתיח בלי חלון עיצוב מהיר")
   
    With Selection.Find
        .Text = "(^+^+^+^+)(*)(^+^+^+^+)(^13)"
        .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

End Sub

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

    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles( _
        "מילת פתיח בלי חלון עיצוב מהיר")
    
    With Selection.Find
        .Text = "(^13)($#$#$#)(* )"
        .Replacement.Text = "\1\3"
        .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
End Sub
    
    
Private Sub part5()
'
'ניקוי הסימנים
'

Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "$$$$$$$$$" & Chr(13)
        .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
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "$$$$$$$$$"
        .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
    
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "$#$#$#"
        .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

Sub part6()

'
'הסרת עיצוב מילה ראשונה בפסקאות שנבחרו
'מאת pcinfogmach
'

    ' Declare variables
    Dim para As Paragraph, paraText As String, numSpaces, i As Integer, _
    spacePos, startSel, endSel As Long, paraRange, slctd As Range, _
    myFrame As Frame, myRange As Range
    
    ' Get number of spaces
    numSpaces = 1
    Set slctd = Selection.Range
    slctd.SetRange Selection.Paragraphs.First.Range.Start, Selection.Paragraphs.Last.Range.End
         
    'תחילת הלולאה
    For Each para In slctd.Paragraphs
    
    ' Check if paragraph meets criteria
    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
 
            ' 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

Selection.Move Unit:=wdCharacter, Count:=1
Selection.End = Selection.End + 1
    Selection.CopyFormat
    
Selection.SetRange Start:=startSel, End:=endSel
Selection.PasteFormat
    Selection.Start = Selection.Start - 3
    
    For Each myFrame In Selection.Frames
    Set myRange = myFrame.Range
    myRange.Select
    Selection.PasteFormat
    myFrame.Delete
    myRange.Collapse wdCollapseEnd
    myRange.Delete wdCharacter, 1
    Next myFrame
    
Application.ScreenRefresh
nxt:
    Next para

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

End Sub

[דאנציג]

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

Sub הגדלה_בחצי_נקודה()
    Selection.Font.SizeBi = Selection.Font.SizeBi + 0.5
End Sub
Sub הקטנה_בחצי_נקודה()
    Selection.Font.SizeBi = Selection.Font.SizeBi - 0.5
End Sub

[pcinfogmach]

קוד להוספת כותרות צד

Option Explicit
Sub כותרות_צד()


Dim numColumns As Integer, currentPara As Paragraph, slctd As Range _
        
'set range
Set slctd = Selection.Range

'start loop
For Each currentPara In slctd.Paragraphs
Application.ScreenUpdating = False
currentPara.Range.Select

'get column width
    numColumns = ActiveDocument.PageSetup.TextColumns.Count
    If numColumns = 2 Then
        Dim columnWidth As Single
        Dim columnWidth2 As Single
        columnWidth = ActiveDocument.PageSetup.TextColumns.Item(1).Width
        columnWidth2 = ActiveDocument.PageSetup.TextColumns.Item(2).Width
    End If
    
'exceptions
If Not currentPara.Range.ComputeStatistics(wdStatisticLines) > 1 _
Or Not currentPara.Range.ComputeStatistics(wdStatisticLines) > 2 Then GoTo nxt

'Get the first sentence of the current paragraph
    Dim firstSentence As String
    Dim words() As String
    words = Split(currentPara.Range.Text, " ")
    firstSentence = words(0) & " " & words(1) & " " & words(2) & " " _
    & words(3) & " " & words(4) & " " & words(5)
    
'get font size set box font size and calc misalignment adjustment accordingly
    Dim fontSize, x, y, z As Single
    fontSize = currentPara.Range.Font.SizeBi - 4
    x = currentPara.Range.Font.SizeBi
    y = x - 8
    z = y * 0.4
    'MsgBox z

'
'Dim spaceWidth As Double
'spaceWidth = currentPara.Range.font.spacing
'Dim spaceWidth As Double
'spaceWidth = ActiveDocument.PageSetup.TextColumns.spacing / 2
'
    
    'get middle of page
    Dim mrgn As Double
    mrgn = ActiveDocument.PageSetup.LeftMargin / 2

    Dim newShape As Shape
    'left column - if para calc is smaller then middle of page
    If ActiveDocument.PageSetup.PageWidth / 2 > currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then
    Set newShape = ActiveDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
            Left:=currentPara.Range.Information(wdHorizontalPositionRelativeToPage) - columnWidth2 - mrgn, _
            Top:=currentPara.Range.Information(wdVerticalPositionRelativeToPage), _
            Width:=mrgn, Height:=50)
        newShape.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphRight
        End If
        
    'right column - if para calc is larger
    If ActiveDocument.PageSetup.PageWidth / 2 < currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then
        Set newShape = ActiveDocument.Shapes.AddTextbox(Orientation:=msoTextOrientationHorizontal, _
            Left:=currentPara.Range.Information(wdHorizontalPositionRelativeToPage), _
            Top:=currentPara.Range.Information(wdVerticalPositionRelativeToPage), _
            Width:=mrgn, Height:=50)
    newShape.TextFrame.TextRange.ParagraphFormat.Alignment = wdAlignParagraphLeft
   
    End If
       'newShape.TextFrame.MarginLeft = 0
       'newShape.TextFrame.MarginRight = 0
        newShape.TextFrame.MarginTop = z 'adjust misalignment
        newShape.TextFrame.MarginBottom = 0
        newShape.Line.Visible = msoFalse
        newShape.TextFrame.TextRange.Text = firstSentence
        newShape.TextFrame.TextRange.Font.SizeBi = 8
        newShape.TextFrame.AutoSize = True
        

    'tiny adjustment
        If ActiveDocument.PageSetup.PageWidth / 2 > currentPara.Range.Information(wdHorizontalPositionRelativeToPage) Then
        newShape.TextFrame.MarginTop = newShape.TextFrame.MarginTop - 0.1
        Else
        newShape.TextFrame.MarginTop = newShape.TextFrame.MarginTop - 0.05
        newShape.TextFrame.MarginLeft = newShape.TextFrame.MarginLeft + 0.04
        End If
        
nxt:
Application.ScreenUpdating = True
Application.ScreenRefresh
    Next currentPara
    
    End Sub
    
Sub מחק_כותרת_צד_בכל_המסמך()
    Dim shp As Shape, i As Integer, shppos, mrgnright, mrgnleft As Single
        
        mrgnleft = ActiveDocument.PageSetup.LeftMargin
        mrgnright = ActiveDocument.PageSetup.PageWidth - mrgnleft
    
    For i = ActiveDocument.Shapes.Count To 1 Step -1
        Set shp = ActiveDocument.Shapes(i)
        shppos = shp.TextFrame.TextRange.Information(wdHorizontalPositionRelativeToPage)
        
        If shppos > mrgnright Or shppos < mrgnleft _
        And shp.Type = msoTextBox And shp.Line.Visible = msoFalse Then
         'And shp.Width = ActiveDocument.PageSetup.LeftMargin / 2 Then
            shp.Delete
        End If
    
    Next i
    End Sub

Sub מחק_כותרות_צד_בעמוד_זה()
Dim shp As Shape, i, currentPage As Integer, _
shppos, mrgnright, mrgnleft As Single
    
    mrgnleft = ActiveDocument.PageSetup.LeftMargin
    mrgnright = ActiveDocument.PageSetup.PageWidth - mrgnleft
    
    currentPage = Selection.Information(wdActiveEndPageNumber)
    Application.ScreenUpdating = False
    For Each shp In ActiveDocument.Shapes
        shppos = shp.TextFrame.TextRange.Information(wdHorizontalPositionRelativeToPage)
        If shp.Anchor.Information(wdActiveEndPageNumber) = currentPage And _
        shppos > mrgnright Or shppos < mrgnleft _
        And shp.Type = msoTextBox And shp.Line.Visible = msoFalse _
        And shp.Anchor.Information(wdActiveEndPageNumber) = currentPage Then
            shp.Select (False)
        End If
    Next shp
    Application.ScreenUpdating = True
    Selection.Delete Unit:=wdCharacter, Count:=1
End Sub

[מאקרו]

@דאנציג כתב בשיתוף | אינצקלופדיה שיתופית עבור קודים של מאקרו - איך עושים את....:

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

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

[pcinfogmach]

@OdedDvir כתב באקסס למתחילים: יצירת מערכת לניהול תורמים:
כמה מוסכמויות בכתיבת קוד:

עבור שמות פונקציות יש להשתמש ב upper camel case, או בתרגום חופשי: כתיבת גמל (?) או כתיבה גמלונית(?) , דהיינו להתחיל כל מילה בשם הפונקציה באות גדולה, למשל:
()GetUserName
או
()CleanMyDesk

עבור שמות משתנים או שמות פרמטרים (לפונקציה) על ידי lower camel case דהיינו להתחיל כל מילה באות גדולה, למעט המילה הראשונה בשם המשתנה, שמתחילה באות קטנה, למשל:
donationsToUpdate
או
MakeMeSomeCoffee(addSugar As Boolean, numberOfCups As Long)

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

[pcinfogmach]

לפעמים כאשר משתמשים בuserform בתצורה של modeless הטקסט שבתוך ה userform לא נראה בהרצה במקרה כזה יש לקרוא לuserform כך:
Userform1.Show
Userform1.Repaint

[121244]

פוסט זה נמחק!

[pcinfogmach]

פוסט זה נמחק!

[pcinfogmach]

חיפוש והחלפה במסמכים מרובים לפי תיקיות

Sub SearchReplaceAllDocumentsInFolder()
    Dim FolderPath As String
    Dim FileName As String
    Dim DocumentPath As String
    Dim doc As Document
    Dim Counter As Long
        
    ' Select the folder containing the documents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    
    ' Initialize counters
    Counter = 0
    
    ' Loop through each file in the folder
    FileName = Dir(FolderPath & "*.doc*")
    Do While FileName <> ""
        ' Construct the full path of the document
        DocumentPath = FolderPath & FileName
        
        ' Open the document
        Set doc = Documents.Open(FileName:=DocumentPath)
        
        ' Perform the search and replace
        With doc.Content.Find
            .ClearFormatting
            .text = "הזן כאן את הטקסט לחיפוש" ' Replace "SearchText" with your desired search text
            .Replacement.ClearFormatting
            .Replacement.text = "הזן כאן את הטקסט להחלפה" ' Replace "ReplaceText" with your desired replacement text
            .Execute Replace:=wdReplaceAll
             End With
        
        ' Save and close the document
        doc.Close SaveChanges:=True
        
        ' Increment counter
        Counter = Counter + 1
        
        ' Move to the next file
        FileName = Dir
    Loop
    
    ' Enable screen updating
    Application.ScreenUpdating = True
    
    ' Display results
    MsgBox "Search and Replace completed." & vbCrLf & _
        "Total Documents Processed: " & Counter
End Sub

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

Sub SearchReplaceAllDocuments()
    Dim FileDialog As FileDialog
    Dim FilePaths As Variant
    Dim FileName As Variant
    Dim srchtxt As String, rplctxt As String
    Dim doc As Document, Counter As Long
    Dim wldcrds As VbMsgBoxResult, srchwldcrds As Boolean
    
   wldcrds = MsgBox("האם ברצונך להשתמש עם תווים כלליים בחיפוש זה?", vbYesNoCancel + vbMsgBoxRight + vbMsgBoxRtlReading + vbQuestion, "חיפוש והחלפה במסמכים מרובים")
    If wldcrds = vbYes Then srchwldcrds = True
    If wldcrds = vbNo Then srchwldcrds = False
    If wldcrds = vbCancel Then Exit Sub
      
    srchtxt = InputBox("הזן טקסט או קוד לחיפוש", "חיפוש והחלפה במסמכים מרובים")
    rplctxt = InputBox("הזן טקסט או קוד להחלפה", "חיפוש והחלפה במסמכים מרובים")
    
    ' Open the file picker dialog
    Set FileDialog = Application.FileDialog(msoFileDialogFilePicker)
    With FileDialog
        .Title = "בחר קבצים (חיפוש בקבצים מרובים לפי בחירת קבצים)"
        .AllowMultiSelect = True
        .Filters.Clear
        .Filters.Add "Word Documents", "*.doc*"
        If .Show = -1 Then
'            FilePaths = .SelectedItems
        
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    
    ' Initialize counter
    Counter = 0
    
    ' Loop through each selected file
    For Each FileName In .SelectedItems
        ' Open the document
        Set doc = Documents.Open(FileName:=FileName)
        
        ' Perform the search and replace
        With doc.Content.Find
            .ClearFormatting
            .Text = srchtxt
            .Replacement.ClearFormatting
            .Replacement.Text = rplctxt
            .MatchWildcards = srchwldcrds
            .Execute Replace:=wdReplaceAll
        End With
        
        ' Save and close the document
        doc.Close SaveChanges:=True
        
        ' Increment counter
        Counter = Counter + 1
    Next FileName
    
    ' Enable screen updating
    Application.ScreenUpdating = True
    
    ' Display results
     ' Display results
    MsgBox "פעולת ההחלפה הסתיימה." & vbCrLf & _
        "מספר המסמכים שבוצע בהם החלפה הם: " & Counter, vbMsgBoxRight, vbMsgBoxRtlReading, "הפעולה הסתיימה"
            
        End If
    End With
End Sub

עריכה שניה:
עכשיו מצאתי את זה
https://wordmvp.com/FAQs/MacrosVBA/BatchFR.htm
יש שם הרבה רעיונות עבור שיפור הקוד

[pcinfogmach]

פתיחת מסמכים מרובים

Sub OpenAllDocumentsInFolder()
    Dim FolderPath As String
    Dim FileName As String
    Dim DocumentPath As String
    
    ' Select the folder containing the documents
    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "Select Folder"
        If .Show = -1 Then
            FolderPath = .SelectedItems(1) & "\"
        Else
            Exit Sub
        End If
    End With
    
    ' Disable screen updating for faster execution
    Application.ScreenUpdating = False
    
    ' Loop through each file in the folder
    FileName = Dir(FolderPath & "*.doc*")
    Do While FileName <> ""
        ' Construct the full path of the document
        DocumentPath = FolderPath & FileName
        
        ' Open the document
        Documents.Open FileName:=DocumentPath
        
        ' Move to the next file
        FileName = Dir
    Loop
    
    ' Enable screen updating
    Application.ScreenUpdating = True
End Sub