שמתי זאת כאופצי' - שתוכל להחליט על אתר באם רוצה הנך להמשיך את המאקרא, או לעצרה. -- השינויים בצבע אדום.
קוד:
[LEFT]Sub ParaForceOneLine()
Dim objPara As Paragraph, myRange As Range[COLOR="red"], i As Integer[/COLOR]
Const DefaultScale = 100, DefaultSize = 6.5
Const MinScale = 85, MinSize = 6
Const ChangeScale = 5, ChangeSize = 0.5
If Len(Selection.Range) = 0 Then
Set myRange = ActiveDocument.Range(Start:=Selection.Range.Start, _
End:=ActiveDocument.Content.End)
Else: Set myRange = Selection.Range: End If
For Each objPara In myRange.Paragraphs
With objPara.Range
If Len(objPara.Range) <= 2 Or .Information(wdAtEndOfRowMarker) Then GoTo sNext
If .Information(wdWithInTable) Then .MoveEnd unit:=wdCharacter, Count:=-1
While .Information(wdFirstCharacterLineNumber) <> _
.Characters(Len(.Text)).Information(wdFirstCharacterLineNumber)
If .Font.Scaling > DefaultScale Or .Font.SizeBi > DefaultSize Then
.Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize: GoTo sWend
End If
If .Font.Scaling >= (MinScale + ChangeScale) Then
.Font.Scaling = .Font.Scaling - ChangeScale
ElseIf .Font.SizeBi >= (MinSize + ChangeSize) Then .Font.SizeBi = .Font.SizeBi - ChangeSize
Else: objPara.Range.Select
[COLOR="red"] i = MsgBox("לא הצליח לדחוס פיסקא זו לתוך שורה אחת" & Chr(13) & "להמשיך?", _
vbOKCancel + vbMsgBoxRight + vbMsgBoxRtlReading)
If i = 1 Then GoTo sNext Else Exit Sub[/COLOR]
End If
sWend:
Wend
End With
sNext:
Next objPara
End Sub[/LEFT]
באם יש לך הרבה שורות כאלו שלא יוכלו להתצמצם לתוך שורה אחת, ואינך רוצה להיות מוטרד כל הזמן ע"י ההודעה הצצה שלא הצליח וכו', אתה יכול גם להחליף (קרוב לסוף המאקרא
את ג' השורות הצבועות בצבע אדום
יחד עם השורה (בצבע שחור
שמעלי' לשורה דלקמן, וזה יצבע את אותה הפיסקא בצבע בולט (כגון כחול
, מבלי להודיע שלא הצליח:
קוד:
[LEFT] Else: .Font.Color = wdColorBlue: GoTo sNext[/LEFT]
באם גם את זה אינך רוצה, אלא פשוט להמשיך (ולאחר מכן כבר תחפש בעצמך אלו שורות לא הצליח לדחוס
, אפשר לרשום (במקום ד' שורות הנ"ל (ג' שבצבע אדום והשורה שמעליהם
):
קוד:
[LEFT] Else: GoTo sNext[/LEFT]
אפשר גם להוסיף, שבמקרה שלא הצליח לדחוס לתוך שורה אחת - שיחזיר את ההצרה והגודל להגדרת ברירת מחדל כרשום בתחילת המאקרא. האם יש לך צורך בזה?
באם כן - תשלב את השורה הבאה בין התיבה "Else:" להבא אחריו - לפי כל ג' האופציות דלעיל:
קוד:
[LEFT].Font.Scaling = DefaultScale: .Font.SizeBi = DefaultSize:[/LEFT]
ובטח יסלח לי על האופציות המרובות דלעיל. קשה לי לשער פשוט מהו הכי נוח בשבילך.