Collecting Data from Word Formfields

[Greg http://gregmaxey.mvps.org/word_tips.htm]

Hello, I know a little about Word and practically nothing about Access.



I send out surveys as Word documents with formfields. I collect the
response in a common directory and compile the results in a Word table.


At the bottom of this message is a bit of code that I cobbled together
and currently use that extracts data from the forms and stores it is a
DataObject (I am not sure if it has anything to do with Access or not).
I then use the data in the dataobject to fill in the Word table.

What I would like to do is elimiate the Word table and have the data
compiled in a permanent Access database. So in laymans terms, I need
code that I can plug into my existing Word macro that will:

Create and open new database
Create the fields and heading rows
For Each File in the folder
Extract the data from the fields
Write data to database fields
Next File
Save database as: C:\myResults.mdb
Close database

I would use that code to replace the following existing code:

'Prepare the database
Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "Name", adVarChar, MaxCharacters
DataList.Fields.Append "FavFood", adVarChar, MaxCharacters
DataList.Fields.Append "FavColor", adVarChar, MaxCharacters
DataList.Open
'Retrieve the data
For i = 1 To UBound(FileArray)
Set myDoc = Documents.Open(FileName:=oPath & FileArray(i), _
Visible:=False)
DataList.AddNew
With myDoc
DataList("Name") = .FormFields("Text1").Result
DataList("FavFood") = .FormFields("Text2").Result
DataList("FavColor") = .FormFields("Text3").Result
.Close
End With
DataList.Update
Next i

I appreciate the help any of you can provide. If I have posted to the
wrong group, please advise. Thanks


Sub TallyData3()
Const adVarChar = 200
Const MaxCharacters = 255
Dim DataList As Object
Dim oPath As String
Dim FileArray() As String
Dim oFileName As String
Dim i As Long
Dim oTbl As Word.Table
Dim myDoc As Word.Document


oPath = GetPathToUse
If oPath = "" Then
MsgBox "A folder was not selected"
Exit Sub
End If
'Identify and count files
oFileName = Dir$(oPath & "*.doc")
ReDim FileArray(1 To 1000) 'A number larger the expected number of
replies
'Add file name to the array
Do While oFileName <> ""
i = i + 1
FileArray(i) = oFileName
'Get the next file name
oFileName = Dir$
Loop
'Resize and preserve the array
ReDim Preserve FileArray(1 To i)
Application.ScreenUpdating = False
'Add the data table with headings
ActiveDocument.Tables.Add Selection.Range, i + 1, 3
Set oTbl = ActiveDocument.Tables(1)
With oTbl
.Cell(1, 1).Range.Text = "Name"
.Cell(1, 2).Range.Text = "Favorite Food"
.Cell(1, 3).Range.Text = "Favorite Color"
End With
'Prepare the database
Set DataList = CreateObject("ADOR.Recordset")
DataList.Fields.Append "Name", adVarChar, MaxCharacters
DataList.Fields.Append "FavFood", adVarChar, MaxCharacters
DataList.Fields.Append "FavColor", adVarChar, MaxCharacters
DataList.Open
'Retrieve the data
For i = 1 To UBound(FileArray)
Set myDoc = Documents.Open(FileName:=oPath & FileArray(i), _
Visible:=False)
DataList.AddNew
With myDoc
DataList("Name") = .FormFields("Text1").Result
DataList("FavFood") = .FormFields("Text2").Result
DataList("FavColor") = .FormFields("Text3").Result
.Close
End With
DataList.Update
Next i
'Display the data
i = 1
DataList.MoveFirst
Do Until DataList.EOF
i = i + 1
oTbl.Cell(i, 1).Range.Text = DataList.Fields.Item("Name")
oTbl.Cell(i, 2).Range.Text = DataList.Fields.Item("FavFood")
oTbl.Cell(i, 3).Range.Text = DataList.Fields.Item("FavColor")
DataList.MoveNext
Loop
Application.ScreenUpdating = True
End Sub
Private Function GetPathToUse() As Variant
'Get the folder containing the files
'Note uses the "Copy Dialog" which enables the "open" option
With Dialogs(wdDialogCopyFile)
If .Display <> 0 Then
GetPathToUse = .Directory
Else
GetPathToUse = ""
Exit Function
End If
End With
If Left(GetPathToUse, 1) = Chr(34) Then
GetPathToUse = Mid(GetPathToUse, 2, Len(GetPathToUse) - 2)
End If