להורדה | מאקרו המרת מרווח שורות בוורד ל'מדויק'

שלמה11

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

שימו לב שיתכנו שינויים קלים במרווח ויש להשתמש במאקרו בזהירות!

אשמח לתגובות אם מישהו נתקל בבאג או שיש לו הצעות לשיפור
‏‏‏‏המרת מרווח בין שורות למדויק .dotm

אם רוצים שהמאקרו יפעל בכל המסמכים ניתן להעתיק את הקובץ הנ"ל לנתיב הבא:
%appdata%\Microsoft\Word\STARTUP

pcinfogmach

פוסט זה נמחק!

pcinfogmach

@שלמה11
סיקרנת אותי
הנה מאקרו לבדיקת התיאוריה:

Sub CalculateLineHeight()
Dim newDoc As Document
Dim i As Single, x As Single

Selection.CopyFormat

Set newDoc = Documents.Add
newDoc.Content = Chr(11)
newDoc.Content.Select
Selection.PasteFormat

Selection.ParagraphFormat.SpaceBefore = 0
Selection.ParagraphFormat.SpaceAfter = 0
Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceSingle

i = Selection.Information(wdVerticalPositionRelativeToPage)

Selection.Collapse Direction:=wdCollapseEnd
Debug.Print "Exact line-height by RelativeToTextBoundary: " & Selection.Information(wdVerticalPositionRelativeToTextBoundary)
x = Selection.Information(wdVerticalPositionRelativeToPage)
Debug.Print "Exact line-height by RelativeToPage: " & x - i
newDoc.Close SaveChanges:=False

End Sub

למעשה אולי @מאקרו או @menajemmendel יש לכם רעיון איך לתקן את הסטייה ש @שלמה11 כבר הזכיר?
כמו"כ מעניין לציין ששני השיטות מחזירים תוצאות שונות במיקצת

עריכה: שיניתי את ה-intger ל- single יותר מדוייק

menajemmendel

@pcinfogmach כתב בלהורדה | מאקרו המרת מרווח שורות בוורד ל'מדויק':

Dim i, x As Integer

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

Dim i
Dim X as integer

pcinfogmach

@menajemmendel

לא הבנתי כוונתך שניהם מוגדרים כ-integer באותה שורה הרבה יותר נקי מלהגדיר אותם בנפרד

תנסה ב-option explicit ותראה ששניהם מוגדרים כראוי

menajemmendel

@pcinfogmach כתב בלהורדה | מאקרו המרת מרווח שורות בוורד ל'מדויק':

@menajemmendel

לא הבנתי כוונתך שניהם מוגדרים כ-integer באותה שורה הרבה יותר נקי מלהגדיר אותם בנפרד

תנסה ב-option explicit ותראה ששניהם מוגדרים כראוי

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

Dim i as integer, x as integer

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

Dim i

ותראה שלא יתן לך שגיאה.

menajemmendel

@pcinfogmach
יותר מזה תנסה:

Sub sample()
Dim i, x As Integer
x = 10
Set i = Selection.Range
End Sub

ותראה שלא יתן שגיאה

menajemmendel

@pcinfogmach אני לא יודע, אבל מה שהעליתי במחקרים שלי, הוא שהבודד וכו', הם גודל בנקודות של הכתב כפול 1.15 ולפי זה עשיתי את החישוב הבא: אבל לא יוצא ממש מדוייק, לא יודע למה

Sub macro3()
Dim ACTUAL_SPACING As Single, font_size As Single, meduyak_spacing As Single
Dim para As Paragraph


For Each para In Selection.Paragraphs
    If para.Format.LineSpacingRule <> wdLineSpaceExactly Then
        ACTUAL_SPACING = LinesToPoints(para.Format.LineSpacing) / 144
        font_size = para.Range.Font.SizeBi
        meduyak_spacing = font_size * 1.15 * ACTUAL_SPACING
        
        With para.Format
            .LineSpacingRule = wdLineSpaceExactly
            .LineSpacing = meduyak_spacing
        End With
    End If
Next para
End Sub

שאלה בקשר לפורום: למה לפעמים הקודים יוצאים צבעונים ולפעמים הכל ירוק?

pcinfogmach

@menajemmendel
זה לא יעבוד בפונטים עם גובה שאינו סטנדרטי

לגבי הקודים הציבעוניים זה בגלל המציד של הקודים לא בנוי דווקא ל-vba אז אם יש משהו בקוד שהוא מסויים ל-vba האו לא מצליח לצבוע אותו

שלמה11

@pcinfogmach כתב בלהורדה | מאקרו המרת מרווח שורות בוורד ל'מדויק':

הנה מאקרו לבדיקת התיאוריה:

לא הבנתי מה רע במאקרו שעשיתי עד ש"קלטתי שהוא נעול בסיסמא..."
אז הנה

Sub המרת_מרווח_בין_שורות_למדויק()

    Dim Firstline As Double
    Dim Secondline As Double
    Dim Exactspacing As Double
    Dim lineCount As Integer
    Dim currentPage As Integer
    Dim paragraphCount As Long
    Dim savedRange As Range
    
    Application.ScreenUpdating = False
    Application.UndoRecord.StartCustomRecord
    Set savedRange = Selection.Range
   
    ' הגדרת מיקום השורה הראשונה והשניה
    Selection.SetRange Start:=Selection.Paragraphs(1).Range.Start, End:=Selection.Paragraphs(1).Range.Start
    Firstline = Selection.Information(wdVerticalPositionRelativeToPage)
    lineCount = Selection.Paragraphs(1).Range.ComputeStatistics(wdStatisticLines)
    currentPage = Selection.Information(wdActiveEndPageNumber)
    If lineCount = 1 Then
        Selection.TypeText text:=Chr(11)
        If currentPage < Selection.Information(wdActiveEndPageNumber) Then
            Firstline = Selection.Information(wdVerticalPositionRelativeToPage)
            Selection.TypeText text:=Chr(11)
        End If
    Else
        Selection.MoveDown unit:=wdLine, Count:=1
    End If
    Secondline = Selection.Information(wdVerticalPositionRelativeToPage)
         ' חישוב מרווח השורות והגדרת המרווח למדויק
    Exactspacing = Secondline - Firstline
    Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
    Selection.ParagraphFormat.LineSpacing = Exactspacing
         ' מחיקת השורות הריקות שנוספו
    If lineCount = 1 Then
        Selection.TypeBackspace
    End If
    If currentPage < Selection.Information(wdActiveEndPageNumber) Then
        Selection.TypeBackspace
    End If
    savedRange.Select
    Application.UndoRecord.EndCustomRecord
    Application.ScreenUpdating = True
End Sub

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

menajemmendel

@שלמה11 כתב בלהורדה | מאקרו המרת מרווח שורות בוורד ל'מדויק':

דרך אגב מאוד מומלץ להוסיף את 3 השורות הראשונות והאחרונות בקוד לכל קוד בvba

נכון, אבל אם אתה מוסיף את זה אז עוד יותר חשוב להוסיף גם error handeling, כמו שהסברתי כאן

שלמה11

על פי הוראותיו של @pcinfogmach מפה
עריכה: 26.01.25

Sub המרת_מרווח_בין_שורות_למדויק2()

    Dim savedRange As Range
    Dim paraRange As Range
    Dim LineSpacing As Double

    Application.ScreenUpdating = False
    Application.UndoRecord.StartCustomRecord

    Set savedRange = Selection.Range

    Set paraRange = Selection.Paragraphs(1).Range
    With paraRange
        If Not .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly Then
            .Collapse wdCollapseStart
            .Text = " " & Chr(11)
            .Collapse wdCollapseStart
            .MoveEnd wdCharacter, 2
            .Collapse wdCollapseEnd
            LineSpacing = .Information(wdVerticalPositionRelativeToTextBoundary)

            .ParagraphFormat.LineSpacingRule = wdLineSpaceExactly
            .ParagraphFormat.LineSpacing = LineSpacing

            .MoveStart wdCharacter, -2
            .Delete
        End If
    End With

    savedRange.Select
    Application.UndoRecord.EndCustomRecord
    Application.ScreenUpdating = True

End Sub

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

שלמה11

הנה מאקרו להסרה:

Sub RemoveLineSpacingExactly()

    Dim Paragraph As Range
    Dim LineSpacingExactly As Double
    Dim LineSpacingSingle As Double
    Dim LineSpacing As Double
    
    Set Paragraph = Selection.Paragraphs(1).Range
    With Paragraph
        If Selection.ParagraphFormat.LineSpacingRule = wdLineSpaceExactly Then
            LineSpacingExactly = .ParagraphFormat.LineSpacing
            .ParagraphFormat.LineSpacingRule = wdLineSpaceSingle
            .Collapse wdCollapseStart
            .text = " " & Chr(11): .Collapse wdCollapseStart
            .MoveEnd wdCharacter, 2: .Collapse wdCollapseEnd
            LineSpacingSingle = .Information(wdVerticalPositionRelativeToTextBoundary)
            .MoveStart wdCharacter, -2: .Delete
            LineSpacing = LineSpacingExactly / LineSpacingSingle
            .ParagraphFormat.LineSpacingRule = wdLineSpaceMultiple
            .ParagraphFormat.LineSpacing = LinesToPoints(LineSpacing)
        End If
    End With
End Sub