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

[דאנציג]

@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

[106]

הכנסת טקסט נבחר (כגון מראה מקום) לתוך סוגריים.

Sub parenthesis()
With Selection.Range
.InsertBefore "("
.InsertAfter ")"
End With
End Sub

[דאנציג]

@106
@dmp הביא פה בעבר הקוד הזה:

'
' סוגריים_עגולות Macro
'
'
Selection.Text = "(" & Selection.Text & ")"
End Sub

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

[מאקרו]

@דאנציג

Selection.MoveEndWhile Cset:=" ", Count:=wdBackward
Selection.InsertAfter (")")
Selection.InsertBefore ("(")

[דאנציג]

@מאקרו
לא עובד לי.

יש לציין לתוסף המוצלח הזה שעושה זאת נפלא.

[pcinfogmach]

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

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

Selection.MoveEndUntil Cset:=" ", Count:=wdForward
Selection.MoveStartUntil Cset:=" ", Count:=wdBackward
Selection.text = "(" & Selection.text & ")"

או אפשר ככה למי שמעדיף

With Selection
    .MoveEndUntil Cset:=" ", Count:=wdForward
    .MoveStartUntil Cset:=" ", Count:=wdBackward
    .text = "(" & .text & ")"
End With

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

[menajemmendel]

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

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

לא הבנתי מה בדיוק המטרה של זה, מה רע בליצור סגנון במסגרת??

[pcinfogmach]

פוסט זה נמחק!

[menajemmendel]

@pcinfogmach האם זה מה שאתה רוצה לעשות?

[pcinfogmach]

פוסט זה נמחק!

[pcinfogmach]

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

עריכה: גירסה מעודכנת
MyParenthesis.zip

[דאנציג]

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

הקטנת והגדלת סוגריים
מאחר ומדובר ביוזרפורם אני מעלה את הקובץ frm במקום קוד
Parenthesis.frm

Errors during load. Refer to
Line 8: Property OleObjectBlob in Parenthesis had an invalid file reference.