chieh
08-20-2012, 01:00 PM
Hi All:
I am fairy new to VBA programming.
I have multiple word fillable form, I need to retrive all the value filled in by the user on each form and insert the value into Excel sheet row by row, each row represents 1 file.
I got the program working using Excel VBA (I paste the full program code at the end), however I try many ways to get the title or label that's on top of each textbox field.
i.e.
First Name [Chieh ], Last name [Zh ], Address [123 confused street ], ... .... ...
I can get the textbox type, 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
At the is point, I use the FormField(i).Name as dynamic heading, 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 for the 2nd time, it crashes toward the end. 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 working with Excel 2003 and word 2003.
Thanks
Chieh
Below is my VBA code.... I am fairly new to VBA, you're welcome to give me suggestion on making the code work faster and more efficient. Thanks Again.
==========================================================
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 intNumberOfField, i As Integer
Dim strPath, strDocFiles, strDisplayText, strFullName, strFieldName, strFieldValue As String
Dim strTempFieldValue As String
Dim wsMessage
Set wsMessage = CreateObject("WScript.Shell")
'For FYI Info....
wsMessage.Popup " This Utility Only Works with *.Doc Files, Not the *.Docx ", 5, "..... Information .....", 4096
Set wbWorkBook = ActiveWorkbook
Set wsWorkSheet = wbWorkBook.Worksheets(1)
Range("A1").Select
'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
'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
'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....
'strFieldName = strFieldName & " - " & ActiveDocument.Bookmarks(strFieldName).Range.Text
.Cells(xRow, i + 1) = strFieldName
Next i
'Bold, left justify the first header row
Rows(xRow & ":" & xRow).Select
Selection.Font.Bold = True
'And add date and time stamp to A1 or the current row
.Cells(xRow, 1) = Now()
Rows(xRow & "1").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
.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
.Cells(xRow, i + 1) = strTempFieldValue
Else
.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
'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
I am fairy new to VBA programming.
I have multiple word fillable form, I need to retrive all the value filled in by the user on each form and insert the value into Excel sheet row by row, each row represents 1 file.
I got the program working using Excel VBA (I paste the full program code at the end), however I try many ways to get the title or label that's on top of each textbox field.
i.e.
First Name [Chieh ], Last name [Zh ], Address [123 confused street ], ... .... ...
I can get the textbox type, 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
At the is point, I use the FormField(i).Name as dynamic heading, 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 for the 2nd time, it crashes toward the end. 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 working with Excel 2003 and word 2003.
Thanks
Chieh
Below is my VBA code.... I am fairly new to VBA, you're welcome to give me suggestion on making the code work faster and more efficient. Thanks Again.
==========================================================
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 intNumberOfField, i As Integer
Dim strPath, strDocFiles, strDisplayText, strFullName, strFieldName, strFieldValue As String
Dim strTempFieldValue As String
Dim wsMessage
Set wsMessage = CreateObject("WScript.Shell")
'For FYI Info....
wsMessage.Popup " This Utility Only Works with *.Doc Files, Not the *.Docx ", 5, "..... Information .....", 4096
Set wbWorkBook = ActiveWorkbook
Set wsWorkSheet = wbWorkBook.Worksheets(1)
Range("A1").Select
'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
'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
'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....
'strFieldName = strFieldName & " - " & ActiveDocument.Bookmarks(strFieldName).Range.Text
.Cells(xRow, i + 1) = strFieldName
Next i
'Bold, left justify the first header row
Rows(xRow & ":" & xRow).Select
Selection.Font.Bold = True
'And add date and time stamp to A1 or the current row
.Cells(xRow, 1) = Now()
Rows(xRow & "1").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
.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
.Cells(xRow, i + 1) = strTempFieldValue
Else
.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
'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