Comment extractor -- VBS

'Extract comments from word documents and save it in excel file
'Author – bijunator

Option Explicit

On Error Resume Next

Dim appObj, exlObj, wBkObj, wShtObj, wrdObj

Dim p, q, r

Dim srcFolder, strFolder, strFile, wordDoc, fileName, docPath, sheetName

Dim myStr

Dim FSO, FLD, FIL

Dim totCmnts, cmntObj, cmntCntr

Dim wordDocName

Dim cmnDlgObj

Dim bullet

Dim response

bullet = Chr(10) & " " & Chr(149) & " "

Do

    response = InputBox("Please enter 1 if want to extract comments from all word files inside a folder" _

    & chr(13) & "Please enter 2 if you want to extract comments from individual word files" _

    & Chr(10) & bullet & "1) Folder" & bullet & "2) File" & Chr(10), "Choose your option...")

    If response = "" Then WScript.Quit  'Detect Cancel

    If IsNumeric(response) Then

      If response =1 or response = 2 Then Exit Do 'Detect value response.

    End If

      MsgBox "You must enter either numeric value 1 or 2", 48, "Invalid Entry"

Loop

MsgBox "You chose : " & response, 64, "Selection..."

'Create the filesystem object

Set FSO = CreateObject("Scripting.FileSystemObject")

Set wrdObj = createObject("Word.Application")

Set exlObj = CreateObject("Excel.Application")

If response = 1 Then '************************first option************************

'MsgBox "Inside option 1"

Set srcFolder = CreateObject("Shell.Application").BrowseForFolder(0, "Choose a folder...", 0)

If (Not srcFolder Is Nothing) Then

strFolder = srcFolder.Items.Item.Path

Else

WScript.Quit

End If

Set srcFolder = Nothing

'MsgBox " Folder --> " & strFolder

fileName = strFolder & "\" & "review_comments_details.xls"

'MsgBox "XLFileName -->" & fileName

q = 0

docPath = strFolder & "\*.doc"

'MsgBox "Word Path -->" & docPath

'Get a reference to the folder you want to search

set FLD = FSO.GetFolder(strFolder)

'loop through the folder and get the file names

For Each Fil In FLD.Files

'     MsgBox Fil.Name

'     MsgBox Fil.Type

     if Fil.Type = "Microsoft Word Document" or Fil.Type = "Microsoft Office Word Document" or Fil.Type = "Word 2007 Document" then

         Set wordDoc = wrdObj.Documents.Open(strFolder & "\" & Fil.Name)

        wrdObj.Application.visible = false

        'wrdObj.Application.DisplayAlerts = False

         With wordDoc

            wordDoc.Activate

            wordDoc.ActiveWindow.ActivePane.View.Type = 3

'           MsgBox "opened word document -->" & wordDoc

           sheetName = Mid(Fil.Name, 1, InStrRev(Fil.Name,".") - 1)

'           MsgBox "Sheet Name -->" & sheetName

           p = 0

           r = 1

           totCmnts = wordDoc.Comments.count

           If totCmnts > 0 Then

              q = q + 1

'              MsgBox "Document No -->" & q

              'Start Excel

'              MsgBox "No of comments -->" & totCmnts

              If q = 1 Then

'                 MsgBox "Opening Excel Workbook"

                 Set wBkObj = exlObj.workbooks.Add()

              End If

'              MsgBox "Adding Workbook Sheet --> " & q

               Set wShtObj = wBkObj.Worksheets(q)

               wShtObj.Name = sheetName

              wShtObj.Cells(r, 1) = "Serial No"

               wShtObj.Cells(r, 2) = "Page No"

               wShtObj.Cells(r, 3) = "Line No"

               wShtObj.Cells(r, 4) = "Author"

               wShtObj.Cells(r, 5) = "Comment Text"

               wShtObj.Cells(r, 6) = "Status"

              For Each cmntObj In wordDoc.Comments

                 r = r + 1

                 p = p + 1

                 wShtObj.Cells(r, 1) = p

                 wShtObj.Cells(r, 2) = cmntObj.Scope.Paragraphs(1).Range.Information(3)

                 wShtObj.Cells(r, 3) = cmntObj.Scope.Paragraphs(1).Range.Information(10)

                 wShtObj.Cells(r, 4) = cmntObj.Author

                 wShtObj.Cells(r, 5) = cmntObj.Range.Text

'                 MsgBox "Comment Serial --> " & p

              Next

           End If

        end with

        wordDoc.Close

     end if

Next

wrdObj.quit

If Not exlObj Is Nothing Then

      MsgBox "Saving Excel Workbook"

     wBkObj.SaveAs fileName

End If

exlObj.quit

ElseIf response = 2 then '************************second option************************

'MsgBox "Inside option 2"

docPath = FSO.GetParentFolderName(WScript.ScriptFullName)

Set cmnDlgObj = CreateObject("UserAccounts.CommonDialog")

cmnDlgObj.Filter = "Word Files|*.doc;*.docx"

cmnDlgObj.FilterIndex = 1

cmnDlgObj.InitialDir = docPath

cmnDlgObj.Flags = 1

If cmnDlgObj.ShowOpen = 0 Then

  MsgBox "No document chosen!" & vbCrLf & "Exiting the program..."

  exlObj.Quit

  wrdObj.Quit

  WScript.Quit

End If

wordDocName = cmnDlgObj.FileName

'Msgbox "word file -->" & wordDocName

Set wordDoc = wrdObj.Documents.Open(wordDocName)

Set wBkObj = exlObj.workbooks.Add()

docPath = FSO.GetParentFolderName(wordDocName)

sheetName = FSO.GetFileName(wordDocName)

'MsgBox "position of dot -->" & InStrRev(sheetName,".")

sheetName = Mid(sheetName, 1, InStrRev(sheetName,".") - 1)

fileName = docPath & "\" & sheetName & "_review_comments_details.xls"

'MsgBox "excel name -->" & fileName

exlObj.Application.DisplayAlerts = False

exlObj.Application.Visible = False

wrdObj.Application.DisplayAlerts = False

wrdObj.Application.Visible = False

totCmnts = wordDoc.Comments.Count

If totCmnts > 0 Then

      wBkObj.Sheets(1).cells(1, 1) = "Serial No"

      wBkObj.Sheets(1).cells(1, 2) = "Page No"

      wBkObj.Sheets(1).cells(1, 3) = "Line No"

      wBkObj.Sheets(1).cells(1, 4) = "Author"

      wBkObj.Sheets(1).cells(1, 5) = "Comment Text"

      wBkObj.Sheets(1).cells(1, 6) = "Status"

      For cmntCntr = 1 to totCmnts

            wBkObj.sheets(1).cells(cmntCntr+1, 1) = cmntCntr

            wBkObj.sheets(1).cells(cmntCntr+1, 2) = wordDoc.Comments(cmntCntr).Scope.Information(3)

            wBkObj.sheets(1).cells(cmntCntr+1, 3) = wordDoc.Comments(cmntCntr).Scope.Information(10)

            wBkObj.sheets(1).cells(cmntCntr+1, 4) = wordDoc.Comments(cmntCntr).Author

            wBkObj.sheets(1).cells(cmntCntr+1, 5) = wordDoc.Comments(cmntCntr).Range.Text

      Next

End If

wrdObj.quit

If Not exlObj Is Nothing Then

     MsgBox "Saving Excel Workbook"

     wBkObj.SaveAs fileName

End If

exlObj.quit

End if '************************end of options************************

If Err.Number <> 0 Then

Msgbox "Error : " & Err.Description

Err.Clear

End If

WScript.Quit