מאקרו להוריד כל מסגרות הטקסט
Sub RemoveAllFramesKeepText()
Dim i As Long
Application.ScreenUpdating = False
For i = ActiveDocument.Frames.Count To 1 Step -1
ActiveDocument.Frames(i).Delete
Next i
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
מאקרו להוריד מירכוז כל המסמך
Sub RemoveSpecialLastLineCentering()
Dim p As Paragraph
Dim r As Range
Dim s As String
Dim pos As Long
Application.ScreenUpdating = False
For Each p In ActiveDocument.Paragraphs
s = p.Range.Text
pos = InStrRev(s, Chr(11))
If pos > 0 Then
Set r = p.Range.Duplicate
' מיד אחרי Shift+Enter
r.Start = p.Range.Start + pos
r.End = r.Start + 1
' מוחק את התו המיוחד שבתחילת השורה האחרונה
If r.End <= p.Range.End Then
r.Delete
End If
' מחליף Shift+Enter ברווח רגיל
Set r = p.Range.Duplicate
r.Start = p.Range.Start + pos - 1
r.End = r.Start + 1
r.Text = " "
End If
Next p
Application.ScreenUpdating = True
MsgBox "Done"
End Sub
מאקרו מדגיש תיבה ראשונה בפיסקה
Sub BoldFirstWordHebrew()
Dim p As Paragraph
Dim r As Range
Dim firstWord As Range
Dim startPos As Long
Dim endPos As Long
Dim ch As String
Dim changedCount As Long
Application.ScreenUpdating = False
For Each p In ActiveDocument.Paragraphs
Set r = p.Range.Duplicate
' Exclude the paragraph mark
If r.End > r.Start Then
r.End = r.End - 1
End If
If r.End <= r.Start Then GoTo NextParagraph
' Skip centered headings
If r.ParagraphFormat.Alignment = _
wdAlignParagraphCenter Then
GoTo NextParagraph
End If
' Skip spaces and tabs at paragraph start
Do While r.Start < r.End
ch = ActiveDocument.Range( _
r.Start, r.Start + 1).Text
If ch = " " Or _
ch = vbTab Or _
ch = Chr(160) Then
r.MoveStart wdCharacter, 1
Else
Exit Do
End If
Loop
If r.Start >= r.End Then GoTo NextParagraph
startPos = r.Start
endPos = startPos
' Find the end of the first word
Do While endPos < r.End
ch = ActiveDocument.Range( _
endPos, endPos + 1).Text
If ch = " " Or _
ch = vbTab Or _
ch = Chr(11) Or _
ch = Chr(13) Or _
ch = Chr(160) Then
Exit Do
End If
endPos = endPos + 1
Loop
If endPos > startPos Then
Set firstWord = ActiveDocument.Range( _
startPos, endPos)
' Apply both regular and Hebrew bold
firstWord.Font.Bold = True
firstWord.Font.BoldBi = True
changedCount = changedCount + 1
End If
NextParagraph:
Next p
Application.ScreenUpdating = True
MsgBox "Done. First words bolded: " & _
changedCount
End Sub
מאקרו שהופך הפניה ע"י מספור להפניה ע"י כוכבית
Sub Footnotes_To_Asterisk_Safe()
Dim doc As Document
Dim i As Long
Dim fn As Footnote
Dim newFn As Footnote
Dim anchorPos As Long
Dim src As Range
Dim dst As Range
Dim tempDoc As Document
Dim tempRng As Range
Set doc = ActiveDocument
If doc.Footnotes.Count = 0 Then
MsgBox "אין הערות שוליים במסמך.", vbInformation
Exit Sub
End If
If MsgBox( _
"נמצאו " & doc.Footnotes.Count & " הערות שוליים." & vbCrLf & vbCrLf & _
"המאקרו יהפוך את כל סימני ההפניה לכוכבית *" & vbCrLf & _
"גם בגוף המסמך וגם בהערות למטה." & vbCrLf & vbCrLf & _
"מומלץ מאוד לשמור עותק גיבוי לפני ההמשך." & vbCrLf & vbCrLf & _
"להמשיך?", _
vbYesNo + vbQuestion, _
"המרת סימני הערות שוליים") <> vbYes Then Exit Sub
Application.ScreenUpdating = False
On Error GoTo ErrorHandler
Set tempDoc = Documents.Add
' עובדים מההערה האחרונה לראשונה
For i = doc.Footnotes.Count To 1 Step -1
Set fn = doc.Footnotes(i)
' שמירת מקום סימן ההפניה בגוף הטקסט
anchorPos = fn.Reference.Start
' שמירת כל תוכן ההערה עם העיצוב
Set src = fn.Range.Duplicate
' מוציאים רק את סימן הפסקה הסופי של Word
If src.End > src.Start Then
If src.Characters.Last.Text = Chr(13) Then
src.End = src.End - 1
End If
End If
' ניקוי המסמך הזמני
tempDoc.Content.Delete
Set tempRng = tempDoc.Range(0, 0)
tempRng.FormattedText = src.FormattedText
' מחיקת ההערה הישנה
fn.Delete
' יצירת הערה חדשה באותו מקום עם *
Set newFn = doc.Footnotes.Add( _
Range:=doc.Range(anchorPos, anchorPos), _
Reference:="*" _
)
' טווח תוכן ההערה החדשה
Set dst = newFn.Range.Duplicate
If dst.End > dst.Start Then
If dst.Characters.Last.Text = Chr(13) Then
dst.End = dst.End - 1
End If
End If
' החזרת התוכן והעיצוב
Set tempRng = tempDoc.Content.Duplicate
If tempRng.End > tempRng.Start Then
If tempRng.Characters.Last.Text = Chr(13) Then
tempRng.End = tempRng.End - 1
End If
End If
dst.FormattedText = tempRng.FormattedText
Next i
tempDoc.Close SaveChanges:=wdDoNotSaveChanges
Application.ScreenUpdating = True
MsgBox _
"הפעולה הסתיימה בהצלחה." & vbCrLf & _
"כל " & doc.Footnotes.Count & _
" ההערות מוצגות כעת בכוכבית *.", _
vbInformation
Exit Sub
ErrorHandler:
Application.ScreenUpdating = True
On Error Resume Next
tempDoc.Close SaveChanges:=wdDoNotSaveChanges
MsgBox _
"המאקרו נעצר בהערה מספר " & i & "." & vbCrLf & _
"שגיאה " & Err.Number & ": " & Err.Description, _
vbCritical
End Sub
מאקרו להצמיד הערות שוליים לתחילת הטור
Sub Remove_Space_After_Footnote_Star_Final()
Dim fn As Footnote
Dim p As Paragraph
Dim r As Range
Dim i As Long
Dim n As Long
Application.ScreenUpdating = False
On Error GoTo ErrHandler
For i = ActiveDocument.Footnotes.Count To 1 Step -1
Set fn = ActiveDocument.Footnotes(i)
Set p = fn.Range.Paragraphs(1)
If p.Range.Characters.Count >= 2 Then
' בוחרים בדיוק את התו השני בפסקה
Set r = p.Range.Characters(2).Duplicate
If Len(r.Text) = 1 Then
If AscW(r.Text) = 32 Then
r.Delete
n = n + 1
End If
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "הסתיים." & vbCrLf & _
"נמחק הרווח ב-" & n & " הערות שוליים.", _
vbInformation
Exit Sub
ErrHandler:
Application.ScreenUpdating = True
MsgBox "נעצר בהערה מספר " & i & vbCrLf & _
Err.Number & " - " & Err.Description, vbExclamation
End Sub
מאקרו שלא יהיה גרשיים ומקפים מסולסלים וכן משוה כל הקוים
Sub MakeQuotesAndDashesStraight()
Application.ScreenUpdating = False
ReplaceAllText ChrW(8220), Chr(34) ' “
ReplaceAllText ChrW(8221), Chr(34) ' ”
ReplaceAllText ChrW(8216), Chr(39) ' ‘
ReplaceAllText ChrW(8217), Chr(39) ' ’
ReplaceAllText ChrW(8211), "-" ' –
ReplaceAllText ChrW(8212), "-" ' —
Application.ScreenUpdating = True
MsgBox "בוצע בהצלחה", vbInformation
End Sub
Private Sub ReplaceAllText(ByVal FindText As String, ByVal ReplaceText As String)
Dim rng As Range
Set rng = ActiveDocument.Content
With rng.Find
.ClearFormatting
.Replacement.ClearFormatting
.Text = FindText
.Replacement.Text = ReplaceText
.Forward = True
.Wrap = wdFindContinue
.Format = False
.MatchCase = False
.MatchWholeWord = False
.MatchWildcards = False
.Execute Replace:=wdReplaceAll
End With
End Sub