Hi Paul:
I got the program working using Excel VBA (I paste the full program code at the end), the info I try to get is the
title or label that's on top or beside each textbox field.
For Example, in my word form, there are following field:
First Name [Chieh ], Last name [Zh ], Address [123 confused street ], ... .... ...
I can get the textbox object type, object name name and result using following command
'Retrieve Full Filename, field type, field name and fieldvalue
strfieldtype = oDoc.FormFields(i).Type
strFieldName = oDoc.FormFields(i).Name
strFieldValue = oDoc.FormFields(i).Result
But can't get the caption, i..e "First Name", "Last Name", "Address"...
I did try the following.
strCaption = oDoc.Bookmarks("Last Name").Range.Text
the value I got is a blank box... i.e. ""
there is 45 formfields in my form, all 45 of them shows this blank box.
I am trying retrieve this caption to use as dynamic column heading in Excel as I am retrieving word form data.
At the is point, I use the FormField(i).Name as dynamic heading for my excel spreadsheet, the program works, but have no success in getting the caption.
My first question is: How do I retrieve the label "First name", "Last Name".... I tried to search through the word object, with no success.... Kindly help.
My second question is. when I ran through my excel vba, 1 or 2 times out of 10, it crashes in the middle. the error messge is " -2147417851: Method 'Item' of object 'FormFields' failed ", any idea on this error? you can copy my code to your local and test it with few word form.
I am fairly new to VBA, eventhough I tried my best to code the program without any hard-coding, I am sure there are improvement can be added, Please feel free to review my code and add, change, modify or suggest for improvement to the code. It would be very helpful for me to gain some expert knowledge and advice from you all.
I am using office 2003
Thank you.
================================================================
Sub WordExtract()
'==
'Add Word object reference library.
'Tools->References - Check the Microsoft Word Object Libary box
Dim wbWorkBook As Workbook
Dim wsWorkSheet As Worksheet
Dim oWord As Word.Application
Dim WordWasNotRunning As Boolean
Dim oDoc As Word.Document
Dim varFileName As Variant
Dim intHeaderRow, intNumberOfField, i As Integer
Dim strPath, strDocFiles, strDisplayText, strFullName, strFieldName, strFieldValue, strCaption, strTempFieldValue As String
Dim wsMessage
Set wsMessage = CreateObject("WScript.Shell")
Set wbWorkBook = ActiveWorkbook
Set wsWorkSheet = wbWorkBook.Worksheets(1)
Range("A1").Select
'For FYI Info....
wsMessage.Popup " This Utility Only Works with *.Doc Files, Not the *.Docx, Press OK To Continue.... ", 5, _
"..... Information .....", 4096
'Get existing instance of Word if it's open; otherwise create a new one
On Error Resume Next
Set oWord = GetObject(, "Word.Application")
If Not Err Then
'Close the word instance if open
oWord.Quit
End If
Set oWord = New Word.Application
On Error GoTo Err_Handler
'Prompt user for the directory where all the word document are located.
With Application.FileDialog(msoFileDialogFolderPicker)
.Show
If .SelectedItems.Count = 1 Then
strPath = .SelectedItems(1)
End If
End With
If strPath = Empty Then
wsMessage.Popup "No folder Selected", 5, "..... Error .....", 4096
Exit Sub
End If
'Get the last row
xRow = wsWorkSheet.Range("A65536").End(xlUp).Row
'Append new Row.....
xRow = xRow + 2
'Keep track number of word document processed
intFileProcessed = 0
'Retreive list of all the word doc files in the given directory
'For now this only works with *.Doc files only. Not the *.Docx, as we only have word office 2003 installed.
'It can be change easily to accomodiate the new docx format.
strDocFiles = Dir(strPath & "\*.Doc")
' Loop through all the word document in this directory, retrieve the info and insert it into the excel sheet.
Do While strDocFiles <> ""
intFileProcessed = intFileProcessed + 1
'Prompt to select single file
'varFileName = Application.GetOpenFilename("Word Files (*.doc; *.docx), *.doc; *.docx")
'varFileName = Application.GetOpenFilename("Word Files (*.doc; *.docx), *.doc; *.docx", , , 1)
'Prompt to select a directory (More than one word file)
Set oDoc = oWord.Documents.Open(strPath & "\" & strDocFiles, Visible:=False)
With wsWorkSheet
'Get the Total Number of user fillable TextBox field in this Document
intNumberOfField = oDoc.FormFields.Count
'Get the Full Name of the current word document
strFullName = oDoc.FullName
'Display processing info in the popup window.....
strDisplayText = "Processing..... " & strFullName & " - Total Field Count: " & Trim(Str(intNumberOfField))
wsMessage.Popup strDisplayText, 1, "Processing", 4096
'If this is the first file being processed, retrieve the header too..
'At this point, haven't figure out how to retrieve the textbox title/label, so just retrieve the actual object name
If intFileProcessed = 1 Then
'Loop through all the fillable fields
For i = 1 To intNumberOfField
strCaption = ""
'Retrieve field object Name and insert/update into Excel cell
strFieldName = oDoc.FormFields(i).Name
'The following commented out line: Trying to get the field caption, didn't work....
'strCaption = oDoc.Bookmarks(strFieldName).Range.Text
'.Cells(xRow, i + 1) = strFieldName & " - " & strCaption
wsWorkSheet.Activate
.Cells(xRow, i + 1) = strFieldName
Next i
'Save the header row # for setting them to Bold after all the files is run.
intHeaderRow = xRow
'Add date and time stamp to first column in the header row
.Cells(xRow, 1).Select
Selection.Value = Now()
Selection.HorizontalAlignment = xlLeft
End If
'Append new Row.....
xRow = xRow + 1
'Update the full name of the word doc in the first column of the current row
wsWorkSheet.Activate
.Cells(xRow, 1) = strFullName
'Retrieve the fillable field result for the current document.
For i = 1 To intNumberOfField
'Retrieve Full Filename, field type, field name and fieldvalue
strfieldtype = oDoc.FormFields(i).Type
strFieldName = oDoc.FormFields(i).Name
strFieldValue = oDoc.FormFields(i).Result
'Display processing info in the popup window.....
'strDisplayText = "Processing..... " & strFullName & " - Total Field Count: " & Trim(Str(intNumberOfField)) _
'& ", _Current Field: " & Trim(Str(i)) & " - " & strFieldName & ", Field Value: " & strFieldValue
'wsMessage.Popup strDisplayText, 1, "Processing", 4096
' Type "wdFieldFormCheckBox" = 71, if it's a check box, the value store is either "1" or "0" for true or false
' the following converts "1" to "True" and "0" to "False" for easier understanding by the users.
If strfieldtype = 71 Then
Select Case strFieldValue
Case "0"
strTempFieldValue = "No"
Case "1"
strTempFieldValue = "Yes"
End Select
wsWorkSheet.Activate
.Cells(xRow, i + 1) = strTempFieldValue
Else
wsWorkSheet.Activate
.Cells(xRow, i + 1) = strFieldValue
End If
'Debug.Print strDisplayText
Next i
End With
oDoc.Close savechanges:=wdDoNotSaveChanges
Set oDoc = Nothing
'Get the next doc
strDocFiles = Dir
Loop
oWord.Quit
'Make sure you release object references.
Set oWord = Nothing
Set oDoc = Nothing
'Set the header row to Bold font only
wsWorkSheet.Activate
wsWorkSheet.Cells.Select
Selection.Font.Bold = False
Rows(intHeaderRow & ":" & intHeaderRow).Select
Selection.Font.Bold = True
'Select the whole Excel sheet and expand all the columns
wsWorkSheet.Cells.Select
Cells.EntireColumn.AutoFit
Range("A1").Select
ActiveWorkbook.Save
Exit Sub
Err_Handler:
Select Case Err
Case -2147022986, 429
Set oWord = CreateObject("Word.Application")
Resume Next
Case 5121, 5174
MsgBox "You must select a valid Word document. " & "No data imported.", vbOKOnly, "Document Not Found"
Case 5941
MsgBox Err.Description
' 'MsgBox "The document you selected does not " _
' & "contain the required form fields. " _
' & "No data imported.", vbOKOnly, _
' "Fields Not Found"
Case Else
MsgBox Err & ": " & Err.Description
oWord.Quit
End Select
End Sub