Convert the VBA as Addin in the word

Option Explicit

' Global constants
Const strPassword = "password"
Const strFolder = "C:\Cleanup1"

' Global variables
Dim objWord As Object
Dim objExcel As Object
Dim objCommentSheet As Object
Dim intRow As Long

Sub CopyCommentsToExcel()

    ' Constants
    Const xlOpenXMLWorkbook = 51
    Const xlTop = -4160
    
    ' Local variables
    Dim objFso As Object
    Dim objShell As Object
    Dim objFolder As Object
    Dim objFile As Object
    Dim objCommentWorkbook As Object
   
    ' Create general use objects
    Set objFso = CreateObject("Scripting.FileSystemObject")
    Set objShell = CreateObject("Shell.Application")
    Set objWord = Application

    objWord.DisplayAlerts = 0

    ' Load Excel, show it
    Set objExcel = CreateObject("Excel.Application")
    objExcel.Visible = True

    ' Create Excel workbook for comments listing, add header row
    Set objCommentWorkbook = objExcel.Workbooks.Add
    Set objCommentSheet = objCommentWorkbook.Sheets(1)
    intRow = 0
    AddComment "File", "Person", "Date", "Comment", "Error"

    ' Access the folder to process
    Set objFolder = objFso.GetFolder(strFolder)

    ' Process all files in folder
    For Each objFile In objFolder.Files

        ' Only process Word and Excel files
        Select Case Left(LCase(objFso.GetExtensionName(objFile.Path)), 3)
            Case "xls"
                DoExcel objFile.Path, objFile.Name
            Case "doc"
                DoWord objFile.Path, objFile.Name
        End Select

    Next

    ' Resize columns
    With objCommentSheet.Cells
        .VerticalAlignment = xlTop
        .EntireColumn.AutoFit
        .EntireRow.AutoFit
    End With

    ' Enable alerts
    objExcel.DisplayAlerts = True
    objWord.DisplayAlerts = -1

End Sub

Sub DoExcel(strPath As String, strName As String)
    ' Local variables
    Dim objWorkbook As Object
    Dim intCount As Long
    Dim i As Long
    Dim objSheet As Object
    Dim objComment As Object

    ' Try to open the file, report and exit if errors
    On Error Resume Next
    Set objWorkbook = objExcel.Workbooks.Open(strPath, 0, True, , strPassword)
    If Err.Number > 0 Then
        AddComment strName, "", "", "", "Error """ & Err.Number & " - " & Err.Description & """ opening workbook."
        On Error GoTo 0
        Exit Sub
    End If

    On Error GoTo 0

    ' Extract any comments and report them
    intCount = 0
    For Each objSheet In objWorkbook.Worksheets
        For Each objComment In objSheet.Comments
            AddComment strName, objComment.Author, "", objComment.Text, ""
            intCount = intCount + 1
        Next
    Next

    ' If no comments found report that
    If intCount = 0 Then
        AddComment strName, "", "", "", "No comments found."
    End If

    ' Close file
    objWorkbook.Close (False)
End Sub

Sub DoWord(strPath As String, strName As String)
    ' Local variables
    Dim objDoc As Object
    Dim intCount As Long
    Dim i As Long

    ' Try to open the file, report and exit if errors
    On Error Resume Next
    Set objDoc = objWord.Documents.Open(strPath, False, True, , strPassword)
    If Err.Number > 0 Then
        AddComment strName, "", "", "", "Error """ & Err.Number & " - " & Err.Description & """ opening document."
        On Error GoTo 0
        objWord.Visible = False
        Exit Sub
    End If

    On Error GoTo 0

    ' Extract any comments and report them
    intCount = 0
    For i = 1 To objDoc.Comments.Count
        With objDoc.Comments(i)
            AddComment strName, .Initial, FormatDateTime(.Date, 2), .Range, ""
            intCount = intCount + 1
        End With
    Next

    ' If no comments found report that
    If intCount = 0 Then
        AddComment strName, "", "", "", "No comments found."
    End If

    ' Close file
    objDoc.Close (False)
End Sub

Sub AddComment(strName As String, strInitial As String, strDate As String, strComment As String, strError As String)
    ' Move to next row of report and add an entry
    intRow = intRow + 1
    objCommentSheet.Cells(intRow, 1).Value = strName
    objCommentSheet.Cells(intRow, 2).Value = strInitial
    objCommentSheet.Cells(intRow, 3).Value = strDate
    objCommentSheet.Cells(intRow, 4).Value = strComment
    objCommentSheet.Cells(intRow, 5).Value = strError
End Sub

Select allOpen in new window