strDocName = "C:\Contracts\" & _
	InputBox("Enter the name of the Word contract " & _
	"you want to import:", "Import Contract")

Set appWord = GetObject(, "Word.Application")
Set doc = appWord.Documents.Open(strDocName)

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
	"Data Source=C:\My Documents\" & _
	"Healthcare Contracts.mdb;"
rst.Open "tblContracts", cnn, _
	adOpenKeyset, adLockOptimistic

Sub GetWordData()
Dim appWord As Word.Application
Dim doc As Word.Document
Dim cnn As New ADODB.Connection
Dim rst As New ADODB.Recordset
Dim strFileName As String
Dim blnQuitWord As Boolean
Dim strPath As String


On Error GoTo ErrorHandling

Set appWord = GetObject(, "Word.Application")

strPath = CurrentProject.Path + "\"

cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;" & _
    "Data Source=" + CurrentProject.Path + "\WorkstationRefresh.mdb;"
rst.Open "tblData", cnn, _
    adOpenKeyset, adLockOptimistic

strFileName = Dir(strPath & "*.doc")

Do While strFileName <> vbNullString

Debug.Print strFileName
If Left$(strFileName, 2) <> "xx" Then
'don't process
Debug.Print strPath & strFileName
Set doc = appWord.Documents.Open(strPath & strFileName)

With rst
.AddNew
    !LName = doc.FormFields("LName").Result  'put in the rest of your fields in the same way
.Update
End With
doc.Close
Set doc = Nothing
Name strPath & strFileName As strPath & "xx" & strFileName
End If
strFileName = Dir()
Loop

If blnQuitWord Then appWord.Quit
cnn.Close
MsgBox "Workstation data imported!"

Cleanup:
Set rst = Nothing
Set cnn = Nothing
Set doc = Nothing
Set appWord = Nothing
Exit Sub
ErrorHandling:
Select Case Err
Case -2147022986, 429
    Set appWord = CreateObject("Word.Application")
    blnQuitWord = True
    Resume Next
Case 5121, 5174
    MsgBox "You must select a valid Word document. " _
        & "No data imported.", vbOKOnly, _
        "Document Not Found"
Case 5941
    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
End Select
GoTo Cleanup
End Sub