A scrubber for all hidden text and and personal information from DOC and DOCX files

CleanWordFile.bas

Private Declare Function OpenClipboard Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function EmptyClipboard Lib "user32" () As Long
Private Declare Function CloseClipboard Lib "user32" () As Long
Private Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Private Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" (ByVal lpszPath As String, ByVal lpPrefixString As String, ByVal wUnique As Long, ByVal lpTempFileName As String) As Long

Sub Clean_Word_File()

'Save the current view state of ShowHiddenText and disable screen updating
    Dim sView As Boolean
    sView = ActiveWindow.View.ShowHiddenText
    ActiveWindow.View.ShowHiddenText = True
    Application.ScreenUpdating = False

    'Reject all Track Changes and delete all comments
    ActiveDocument.Revisions.RejectAll

    'Remove all document personal information
    'ActiveDocument.RemoveDocumentInformation (wdRDIAll)

    'Call Remove_hidden_text_with_inspector
    'Call DeleteEmptyTable
    'Call Delete_All_Hidden_Char
    'Call DeleteEmptyTablerows
    'Call Delete_All_Hidden_Bookmarks
    'Call delEmptyBkmksSentences
    'Call Remove_Blank_Pages_Macro
    Call FindEmptyHeading(ActiveDocument.Styles(wdStyleHeading1))
    Call FindEmptyHeading(ActiveDocument.Styles(wdStyleHeading3))
    Call Remove_All_Strikethrough
    Call Remove_All_Hightlights
    Call Change_All_to_black

    'Restore Original ShowHiddenText and re-enable screen updating
    ActiveWindow.View.ShowHiddenText = sView
    Application.ScreenUpdating = True

End Sub

Sub ClearClipboard()
    OpenClipboard (0&)
    EmptyClipboard
    CloseClipboard
End Sub
          
          
Sub Delete_All_Hidden_Bookmarks()
Dim objBookmark As Bookmark
    Dim rng As Range
    For Each objBookmark In ActiveDocument.Bookmarks()
        If objBookmark.Empty = True Then
            objBookmark.Delete
        ElseIf objBookmark.Range.Text = Chr(13) + Chr(10) Then
            objBookmark.Select
            ActiveWindow.Selection.Cut
        ElseIf objBookmark.Range.Text = Chr(13) Then
            objBookmark.Select
            ActiveWindow.Selection.Cut
        ElseIf objBookmark.Range.Font.Hidden = True Then
            objBookmark.Select
            ActiveWindow.Selection.Cut
        End If
    Next
    Call ClearClipboard
End Sub
    
Sub Remove_all_Comments()
    For Each cmt In ActiveDocument.Comments
        cmt.Delete
    Next
End Sub
                                        
Sub Remove_hidden_text_with_inspector()
'use the builtin Document Inspector to remove all hidden text
    Dim Status As MsoDocInspectorStatus
    Dim Results As String
    Debug.Print ActiveDocument.DocumentInspectors.Count

    For Each instance In Application.ActiveDocument.DocumentInspectors
        If instance.Name = "Hidden Text" Then instance.Inspect
        '(Status, Results)
        If Status = 1 Then instance.Fix [Status, Results]
    Next
End Sub

Sub Delete_All_Hidden_Char()
    'Find each hidden text character and replace with null
    ActiveWindow.View.ShowHiddenText = True
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "?"
        .Font.Hidden = True
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub Remove_All_Strikethrough()
    'Find each strikethrough character and remove all strikethrough
    ActiveWindow.View.ShowHiddenText = True
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    With Selection.Find
        .Text = "?"
        .Font.StrikeThrough = True
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = True
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub

Sub Remove_All_Hightlights()
    'remove all highlight
    Dim objDoc As Document
    Dim objRange As Range
    Dim strHighlightColor As String

    objDoc = ActiveDocument
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting

    With Selection
        .HomeKey Unit:=wdStory
        With Selection.Find
            .Highlight = True
            Do While .Execute
                If Selection.Range.HighlightColorIndex <> wdNoHighlight Then
                    objRange = Selection.Range
                    objRange.HighlightColorIndex = wdNoHighlight
                    Selection.Collapse (wdCollapseEnd)
                End If
            Loop
        End With
    End With
    Selection.Find.ClearFormatting
    Selection.Find.Replacement.ClearFormatting
    objDoc = Nothing
End Sub

Sub Change_All_to_black()
'Select Entire Document and change everything to black
Set myRange = Selection.Range
myRange.WholeStory
myRange.Font.Color = wdBlack
End Sub

Sub delEmptyBkmksSentences()
  'from mdmackillop - http://www.vbaexpress.com/forum/archive/index.php/t-25813.html
    Dim objBookmark As Bookmark
    Dim rng As Range
    For Each objBookmark In ActiveDocument.Bookmarks()
        If objBookmark.Range.Text = "" Or objBookmark.Range.Text = Chr(13) Then
            Set rng = objBookmark.Range
            rng.Expand Unit:=wdSentence
            rng.Delete
        End If
    Next
End Sub

Sub DeleteEmptyTablerows()
    Dim Tbl As Table, cel As Cell, i As Long, n As Long, fEmpty As Boolean

    With ActiveDocument
        For Each Tbl In .Tables
            n = Tbl.Rows.Count
            For i = n To 1 Step -1
                fEmpty = True
                For Each cel In Tbl.Rows(i).Cells
                    On Error Resume Next
                    If Len(cel.Range.Text) > 2 Then
                        fEmpty = False
                        Exit For
                    End If
                Next cel
                If fEmpty = True Then Tbl.Rows(i).Delete
            Next i
        Next Tbl
    End With
    cel = Nothing: Tbl = Nothing
End Sub
Sub DeleteEmptyTable()
    Dim Tbl As Table, cel As Cell, fEmpty As Boolean

    With ActiveDocument
        For Each Tbl In .Tables
            fEmpty = True
            For Each cel In Tbl.Range.Cells
                On Error Resume Next
                If Len(cel.Range.Text) > 2 Then
                    fEmpty = False
                    Exit For
                End If
            Next cel
            If fEmpty = True Then Tbl.Delete
        Next Tbl
    End With
    cel = Nothing: Tbl = Nothing
End Sub

Public Function Remove_Blank_Pages_Macro()
    'Found in:
    'http://www.vbaexpress.com/forum/showthread.php?38245-Solved-Searching-and-deleteing-empty-pages-but-NOT-hidden-text
    'By Hvorfor - 07-15-2011
    Dim NumberOfPages As Long
    Dim CurrentPage As Long
    CurrentPage = 1
    NumberOfPages = Selection.Information(wdNumberOfPagesInDocument)

    Selection.GoTo What:=wdGoToSection, Which:=wdGoToFirst
    Selection.ExtendMode = True
    Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
    For CurrentPage = 1 To NumberOfPages
        If CurrentPage = NumberOfPages Then
            Selection.EndKey Unit:=wdStory, Extend:=wdExtend
        End If
        Selection.ExtendMode = False
        If isBlankSelection Then
            If CurrentPage = NumberOfPages Then
                Selection.Delete
                Selection.ExtendMode = True
                Selection.GoTo What:=wdGoToLine, Which:=wdGoToPrevious, Count:=1
                If isBlankSelection Then
                    Selection.Delete
                End If
                Exit For
            End If
            Selection.Delete
            Selection.ExtendMode = True
            Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
        Else
            Selection.Collapse (wdCollapseEnd)
            Selection.ExtendMode = True
            Selection.GoTo What:=wdGoToPage, Which:=wdGoToNext, Count:=1
        End If
    Next CurrentPage
    Selection.Collapse (wdCollapseEnd)
    Selection.ExtendMode = False
End Function

Public Function isBlankSelection()
    'Found in:
    'http://www.vbaexpress.com/forum/showthread.php?38245-Solved-Searching-and-deleteing-empty-pages-but-NOT-hidden-text
    'By Hvorfor - 07-15-2011
    Dim lOriginalValue As Boolean
    With ActiveWindow.View
        'store it
        lOriginalValue = .ShowHiddenText
        'change it
        .ShowHiddenText = True
        For Each c In Selection.Characters
            If (c <> vbCr And c <> vbTab And c <> vbFormFeed And c <> " ") Then
                isBlankSelection = False
                'restore it
                .ShowHiddenText = lOriginalValue
                Exit Function
            End If

        Next
        isBlankSelection = True
        'restore it
        .ShowHiddenText = lOriginalValue
    End With
End Function

Public Function Get_Temp_File_Name(Optional sPrefix As String = "", Optional sExtensao As String = "") As String
    'from "http://www.exceltoolset.com/how-to-get-temp-file-name-using-vba/"
      Dim sTmpPath As String * 512
      Dim sTmpName As String * 576
    Dim nRet As Long
    Dim F As String
    nRet = GetTempPath(512, sTmpPath)
    If (nRet > 0 And nRet < 512) Then
        nRet = GetTempFileName(sTmpPath, sPrefix, 0, sTmpName)
        If nRet <> 0 Then F = Left$(sTmpName, InStr(sTmpName, vbNullChar) - 1)
        If sExtensao > "" Then
            Kill (F)
            If Right(F, 4) = ".tmp" Then F = Left(F, Len(F) - 4)
            F = F & sExtensao
        End If
        Get_Temp_File_Name = F
    End If
End Function
Sub Create_New_Copy()
    Dim myCopy As Document
    Dim docName As String

    ' Retrieve name of ActiveDocument
    docName = ActiveDocument.Name

    ' Test if Activedocument has previously been saved
    If ActiveDocument.Path = "" Then

        ' If not previously saved
        MsgBox ("The current document must be saves at least once.")

    Else

        ' If previously saved, create a copy
        myCopy = Documents.Add(ActiveDocument.FullName)
        docName = Get_Temp_File_Name(docName, ".docx")
        'MsgBox docName
        ' save copy
        myCopy.SaveAs2 FileName:=docName
        myCopy.Save
        ' Close copy
        myCopy.Close

    End If
End Sub

Sub FindEmptyHeading(ByVal style2breplaced As Style)
    '
    ' Find Specified Style that are hidden and convert them to Normal
    '
    '

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles(style2breplaced)
    Selection.Find.Font.Hidden = True
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles(style2breplaced)
    Selection.Find.Replacement.Font.Hidden = True
    With Selection.Find
        .Text = ""
        .Replacement.Text = ""
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll


    Selection.Find.ClearFormatting
    Selection.Find.Font.Hidden = True
    Selection.Find.Style = ActiveDocument.Styles(style2breplaced)
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles(wdStyleNormal)
    Selection.Find.Replacement.Font.Hidden = True
    With Selection.Find
        .Text = "^p^p^p"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = True
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll

    Selection.Find.ClearFormatting
    Selection.Find.Style = ActiveDocument.Styles(style2breplaced)
    Selection.Find.Replacement.ClearFormatting
    Selection.Find.Replacement.Style = ActiveDocument.Styles(wdStyleNormal)
    With Selection.Find
        .Text = "^b"
        .Forward = True
        .Wrap = wdFindContinue
        .Format = True
        .MatchCase = False
        .MatchWholeWord = False
        .MatchWildcards = False
        .MatchSoundsLike = False
        .MatchAllWordForms = False
    End With
    Selection.Find.Execute Replace:=wdReplaceAll
End Sub