מאקרו לוורד - ספירת תוים בקבצים מרובים

הייתי צריך לעשות הערכה של כמות התוים שיש בפרוייקט ענק... 175 קבצים.
ניסיתי את האפשרות של חיבור כל הקבצים לקובץ אחד, ואחר כך לבצע ספירת תוים. זה לא הלך כל כך טוב. 175 קבצים שיש בהם סך הכל 45 מיליון תוים [!] גרמו לתוכנת הוורד לחוויה לא נעימה, וגם לא ברורה.

פיתרון בצורה של מאקרו

אז חיפשתי פיתרון בצורה של מאקרו ל-Word ומצאתי את אשר חיפשתי דווקא באתר של מייקרוסופט עצמם - כאן.
הבעיה שאני לא יודע לכתוב בשפת ה-VBA, וכשגיליתי שזה לא סופר הערות שוליים הלכתי וחיפשתי משהו אחר. ולא כל כך מצאתי. רק ראיתי כמה אפשרויות ושיטות נוספות וניסיתי לשלב ביניהן בתוך המאקרו. נראה שזה הצליח. והנה המאקרו לפניכם.
[על הדרך המאקרו מציין אם הקובץ מכיל הערות שוליים או הערות סיום].

כיצד המאקרו עובד

מאקרו לספירת כמות תוים בקבצים מרובים של וורד:
ראשית צריך לשים את כל הקבצים בתקייה אחת [גם קבצי doc גם docx וגם rtf]
מפעילים את המאקרו [דרך הוורד]
הוא מבקש לבחור תקייה - בוחרים את התקייה שבה הקבצים
המאקרו פותח כל אחד מהקבצים, לוקח את הנתונים וסוגר את הקובץ
ומעדכן את הנתונים בקובץ נפרד בצורה של טבלה.
זהו.
[אם מדובר בקבצים רבים כמו הדוגמא שהבאתי אז צריך קצת סבלנות... איזה 10 דקות].

כך נראית התוצאה פחות או יותר

הקוד של המאקרו נמצא בסמוך...

​Sub CountCharsForMultipleWordFiles()
'
' CountCharsForMultipleWordFiles
' ספירת כמות תוים במסמכים מרובים כולל הערות שוליים והערות סיום.
'
Dim fd As FileDialog
Dim DocSource As Document
Dim doctarget As Document

Dim tblTarget As Table
Dim tblrow As Row

Dim bNotRtfDone As Boolean
Dim bHasFootNotes As Boolean
Dim bHasEndNotes As Boolean

Dim lDocumntChars As Long
Dim lTotalCount As Long

Dim lFootnoteChars As Long
Dim lFootnoteCount As Long
Dim lEndnoteChars As Long
Dim lEndnoteCount As Long

Dim sStr As String

Set fd = Application.FileDialog(msoFileDialogFolderPicker)

With fd
    .Title = "בחר את התקיה שמכילה את הקבצים"
    If .Show = -1 Then
        strFolder = .SelectedItems(1) & "\"
    Else
        MsgBox "לא נבחרה תקיה.", vbMsgBoxRtlReading
        Exit Sub
    End If
End With

strFile = Dir$(strFolder & "*.doc*")

If strFile = "" Then
    bNotRtfDone = True
    strFile = Dir$(strFolder & "*.rtf")
    If strFile = "" Then
        MsgBox "התקיה לא מכילה קבצי וורד.", vbMsgBoxRtlReading
        Exit Sub
    End If
End If

Set doctarget = Documents.Add
Set tblTarget = doctarget.Tables.Add(doctarget.Range, 1, 3)

With tblTarget
    With .Range.Font
        .SizeBi = 9
        .Size = 8
    End With
    With .Cell(1, 1).Range
        .Text = "שם הקובץ"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = True
    End With
    With .Cell(1, 2).Range
        .Text = "הקובץ מכיל הערות שוליים/סיום"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = False
        .Font.SizeBi = 8
    End With
    With .Cell(1, 3).Range
        .Text = "כמות תוים עם רווחים"
        .Font.ColorIndexBi = wdBlue
        .Font.BoldBi = True
    End With
End With

re:
While strFile <> ""
    bHasFootNotes = False
    bHasEndNotes = False
    Set DocSource = Documents.Open(strFolder & strFile)
    lFootnoteCount = DocSource.Footnotes.Count
    lEndnoteCount = DocSource.Endnotes.Count
    lDocumntChars = DocSource.Characters.Count - DocSource.Paragraphs.Count - lEndnoteCount
    Set objRange = DocSource.StoryRanges
    
    If lFootnoteCount > 0 Then
    bHasFootNotes = True
     For Each objRange In DocSource.StoryRanges
       If objRange.StoryType = wdFootnotesStory Then
         lFootnoteChars = objRange.Characters.Count - lFootnoteCount
         lDocumntChars = lDocumntChars + lFootnoteChars
       End If
     Next objRange
    End If
    
    If lEndnoteCount > 0 Then
    bHasEndNotes = True
     For Each objRange In DocSource.StoryRanges
       If objRange.StoryType = wdEndnotesStory Then
         lEndnoteChars = objRange.Characters.Count - lEndnoteCount
         lDocumntChars = lDocumntChars + lEndnoteChars
       End If
     Next objRange
    End If

    Set tblrow = tblTarget.Rows.Add
    With tblrow.Range.Font
        .BoldBi = False
        .ColorIndexBi = wdAuto
    End With
    
    With tblrow
        .Cells(1).Range.Text = DocSource.name
        With .Cells(2).Range
            .Font.ColorIndexBi = wdGray50
            If (bHasFootNotes + bHasEndNotes) Then
                If bHasFootNotes Then
                    If bHasEndNotes Then
                        sStr = "הערות שוליים + סיום"
                    Else
                        sStr = "הערות שוליים"
                    End If
                Else
                    sStr = "הערות סיום"
                End If
            Else
                sStr = "---"
            End If
            .Text = sStr
        End With
        With .Cells(3).Range
            .Font.ColorIndexBi = wdGray50
            .Text = lDocumntChars
        End With
    End With
    
    lTotalCount = lTotalCount + lDocumntChars
    DocSource.Close wdDoNotSaveChanges

    strFile = Dir$()
Wend

If Not bNotRtfDone Then
    bNotRtfDone = True
    strFile = Dir$(strFolder & "*.rtf")
    GoTo re
End If

Set tblrow = tblTarget.Rows.Add

With tblrow
    .Range.Font.BoldBi = True
    .Range.Font.ColorIndexBi = wdRed
    .Cells(1).Range.Text = "סך הכל"
    .Cells(3).Range.Text = lTotalCount
End With

doctarget.Activate

End Sub