עזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן

[pcinfogmach]

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

Option Explicit
Dim currentPageNumber As Long
 
Sub AlignColumnsInSelection()
    Dim originalRange As range
    Dim currentPageRange As range, currentSectionRange As range
    Dim startPageNumber As Long, endPageNumber As Long
    Dim currentSection As Section
    
    On Error GoTo errorHandle ' Enable error handling.
    Application.UndoRecord.StartCustomRecord "ééùåø èåøéí"
    
    ' Save the initial selection range to restore it after alignment.
    Set originalRange = Selection.range
    ExpandSelectionToEndOfPageOrSection originalRange
    
    ' Get the first and last page numbers within the selection.
    startPageNumber = originalRange.Characters.First.Information(wdActiveEndPageNumber)
    endPageNumber = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
    
    ' Loop through each page within the selection.
    For currentPageNumber = startPageNumber To endPageNumber
        ' Navigate to the current page.
        Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=currentPageNumber
        Application.ScreenUpdating = False ' Turn off screen updating for better performance.
    
        ' Select the entire content of the current page.
        Set currentPageRange = Selection.Bookmarks("\page").range
        
        ' Process sections within the page, if applicable.
        If currentPageRange.Sections.Count > 1 Then
            For Each currentSection In currentPageRange.Sections
                Set currentSectionRange = currentSection.range
                ' Adjust the section range based on the page number.
                If currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) = currentPageNumber Then
                    currentSectionRange.End = currentPageRange.End
                ElseIf currentSectionRange.Characters.First.Information(wdActiveEndPageNumber) < currentPageNumber Then
                    currentSectionRange.Start = currentPageRange.Start
                End If
                
                ' Align the section if it has two text columns.
                If currentSectionRange.PageSetup.TextColumns.Count = 2 And currentSectionRange.InRange(originalRange) Then
                    DoAlignment currentSectionRange
                End If
            Next currentSection
            
        ElseIf currentPageRange.PageSetup.TextColumns.Count = 2 Then
            ' Align the page if there is only one section.
            DoAlignment currentPageRange
        End If
        
        Application.ScreenUpdating = True 'Re-enable screen updating for visual progress.
        DoEvents ' Allow system events to process to avoid freezing.
    Next currentPageNumber
    
    ' Restore the original selection.
    originalRange.Select
    
    ' End the custom undo record
    Application.UndoRecord.EndCustomRecord
    
    Exit Sub
 
errorHandle:
Call ErrorHandler
End Sub
Sub ExpandSelectionToEndOfPageOrSection(ByRef originalRange As range)
    ' Declare variables to hold the start and end positions of sections and pages
    Dim endSection, startSection As Long
    Dim endPage, startPage As Long
    
    ' Get the end position of the last section and the start position of the first section in the range
    endSection = originalRange.Sections.Last.range.End
    startSection = originalRange.Sections.First.range.Start
 
    ' Get the page number where the range ends and where it starts
    endPage = originalRange.Characters.Last.Information(wdActiveEndPageNumber)
    startPage = originalRange.Characters.First.Information(wdActiveEndPageNumber)
    
    ' Move the selection to the end page and get the end position of that page
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=endPage
    endPage = Selection.Bookmarks("\page").End
    
    ' Move the selection to the start page and get the start position of that page
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToAbsolute, Name:=startPage
    startPage = Selection.Start
    
    ' Extend the range's end position to the end of the section or page, whichever comes first
    If endSection < endPage Then
        If originalRange.End < endSection Then originalRange.End = endSection
    Else
        If originalRange.End < endPage Then originalRange.End = endPage
    End If
    
    ' Extend the range's start position to the start of the section or page, whichever comes last
    If startSection > startPage Then
        If originalRange.Start > startSection Then originalRange.Start = startSection
    Else
        If originalRange.Start > startPage Then originalRange.Start = startPage
    End If
End Sub
 
 
 
Sub DoAlignment(ActionRange As range)
    
    Dim firstColumnRange, secondColumnRange As range ' Declare variables for the ranges representing the two columns.
    Dim columnBoundaryX, column1BoundaryY, column2BoundaryY As Double ' Variables to store the column boundary and vertical positions of the columns.
    Dim positionDifference As Single ' Stores the difference in vertical positions to adjust spacing between paragraphs.
    Dim firstColumnBottomMarker, secondColumnBottomMarker As range ' Variables to mark the bottom of each column.
    Dim currentParagraph As Paragraph ' Variable to iterate through the paragraphs.
        
    On Error GoTo errorHandle
    ' Duplicate the selected range to represent the first and second columns.
    Set firstColumnRange = ActionRange.Duplicate
    Set secondColumnRange = ActionRange.Duplicate
    
    ' Determine the column boundary using the horizontal position on the page.
    ActionRange.Select
    With Selection
        .EndKey ' Move the cursor to the end of the selection.
        .HomeKey ' Move the cursor back to the start of the selection.
         columnBoundaryX = .Information(wdHorizontalPositionRelativeToPage) + (.PageSetup.TextColumns(1).SpaceAfter) ' Set the boundary between the columns.
        Set secondColumnBottomMarker = .range ' Store the bottom position of the second column.
    End With
    
    ' Configure the first column range.
    With firstColumnRange
        .Collapse ' Collapse the range to its starting point.
 
        ' Expand the first column range to include paragraphs until it reaches the column boundary.
        Do While .Next(wdParagraph).Characters.Last.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
            .MoveEnd wdParagraph, 1 ' Extend the range by one paragraph.
        Loop
        
        ' Fine-tune the boundary by moving character by character until it reaches the column boundary.
        Do While .Next.Information(wdHorizontalPositionRelativeToPage) > columnBoundaryX
                 .MoveEnd wdCharacter, 1 ' Extend the range by one character.
        Loop
 
        secondColumnRange.Start = .End
    End With
    
    ' Select the first column range to capture its bottom position.
    firstColumnRange.Select
    With Selection
        .EndKey ' Move to the end of the first column.
        .HomeKey ' Move back to the start.
    End With
    Set firstColumnBottomMarker = Selection.range ' Store the bottom position of the first column.
    
    ' Retrieve the vertical positions of the bottom markers for both columns.
    column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
    column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
    
    ' Adjust spacing between paragraphs to align the bottoms of both columns.
    ' This loop increases spacing if the first column is shorter.
    Do While column2BoundaryY > column1BoundaryY
        ' Calculate the difference in vertical positions, divided by the number of paragraphs.
        positionDifference = (column2BoundaryY - column1BoundaryY) / firstColumnRange.Paragraphs.Count
        
        ' Exit if the difference is too large or negative.
        If positionDifference > 40 Or positionDifference < 0 Then Exit Do
        
        ' Increase the spacing after each paragraph in the first column.
        For Each currentParagraph In firstColumnRange.Paragraphs
            If currentParagraph.range.Characters.Last.InRange(firstColumnRange) Then
                currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                ' Update the bottom position of the first column.
                 column1BoundaryY = firstColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                ' Exit the loop if the bottom of the first column aligns with the second column.
                If column1BoundaryY >= column2BoundaryY Then
                    Exit For
                End If
            End If
        Next currentParagraph
           
    Loop
    
    ' If the second column is shorter, adjust its paragraph spacing similarly.
    Do While column1BoundaryY > column2BoundaryY
        ' Calculate the spacing difference for the second column.
        positionDifference = (column1BoundaryY - column2BoundaryY) / secondColumnRange.Paragraphs.Count
        
        ' Exit if the difference is too large.
        If positionDifference > 40 Then Exit Do
        
        ' Increase the spacing after each paragraph in the second column.
        For Each currentParagraph In secondColumnRange.Paragraphs
            If currentParagraph.range.Characters.Last.InRange(secondColumnRange) Then
                currentParagraph.range.Select
                currentParagraph.SpaceAfter = currentParagraph.SpaceAfter + positionDifference
                ' Update the bottom position of the second column.
                column2BoundaryY = secondColumnBottomMarker.Information(wdVerticalPositionRelativeToPage)
                ' Exit the loop if the second column aligns with the first column.
                If column2BoundaryY >= column1BoundaryY Then Exit For
            End If
        Next currentParagraph
        
    Loop
    
Exit Sub
errorHandle:
Call ErrorHandler
End Sub
 
Sub ErrorHandler()
    ' Handle errors and clean up.
    Application.UndoRecord.EndCustomRecord
    Application.ScreenUpdating = True
    
    Dim msg As String
    Debug.Print "Error Number: " & Err.Number & vbCrLf & _
          "Source: " & Err.Source & vbCrLf & _
          "Description: " & Err.Description & vbCrLf & _
          "Help Context: " & Err.HelpContext & vbCrLf & _
          "Help File: " & Err.HelpFile & vbCrLf & _
          "Page Number: " & currentPageNumber
End Sub

[יאיר הבהיר]

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

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

[pcinfogmach]

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

[א.מ.]

מחזיר שגיאה.

[pcinfogmach]

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

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

[יאיר הבהיר]

@pcinfogmach ניסיתי שוב ונראה לי שהוא לא מיישר כלום...
‏‏הכתב והמכתב - עותק.docx

[pcinfogmach]

@יאיר-הבהיר
אוקיי אני רואה מה הבעיה אתה עשית קיפול לספר נכון?

[יאיר הבהיר]

@pcinfogmach צודק.
קשור?

[pcinfogmach]

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

[יאיר הבהיר]

@pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...
‏‏הכתב והמכתב - עותק.docx

[יאיר הבהיר]

@pcinfogmach אגב, כדאי שתהיה גם פקודה לסוף הקטע, שאם יש קטע שנגמר כך:

אז שיישר אותו כך:

[צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

[pcinfogmach]

@יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

[צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

[pcinfogmach]

@יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

@pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

[יאיר הבהיר]

@pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

@יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

@pcinfogmach ניסיתי גם בלי קיפול ספר ועדיין לא עובד לי...

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

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

[shishko]

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

[pcinfogmach]

@shishko
לא ניסיתי. אתה ניסית והצליח?

[shishko]

@pcinfogmach לא, בדיוק לפני כמה דקות חשבתי על זה באופן ידני ודאי ניתן לעשות את זה על אף א"א לעשות יישור לסוף השורה ולכן ישנם אי אלו הבדלים חסרון נוסף שניתן לעשו שני שורות רק עם רווח ביניהם של נקודה 1 ולא 1.5 כמו הגדרת ברירת המחדל השאלה אם אין דרך להתגבר על זה?
וגם אם לא אולי ניתן לעשות את זה כאפשרות נוספת כשהמעלה שהמילה הראשונה היא חלק מהטקסט ויותר קל לבטל את זה במיקום מסויים!!
צריך לבדוק אם אפשר בעיקרון להשתמש בזה גם כשאין סינית על המחשב וכל הבעיה שטכנית זה לא מופיע (דרך אגב אם כן אפשר להוסיף את האפשרויות שיש בסינית לתוסף).
אם יהיה לי זמן אני ינסה לעבוד על זה.

[pcinfogmach]

@shishko
אוקיי תעדכן אותי
ואם תוכל לשלוח לי מאקרו מוכן כמובן הדבר יקל עלי

[יאיר הבהיר]

@pcinfogmach כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

@יאיר-הבהיר כתב בעזרה | מישהו יכול לבדוק לי את המאקרו יישור טורים דלהלן:

[צריך שיוגדר לו מעבר מקטע מיד בסוף הטקסט, ואז הוא מתיישר כמעט בכל המקרים]

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

ffc2cf7d-3590-4dc3-8af9-c20a05afa16f-bandicam 2024-10-27 01-45-12-677.mp4

[pcinfogmach]

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

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