Code:
Dim objwa
Dim objwd
Dim currpath
Dim sfile
Dim sText, sLine, sERR, sfilename
Dim aLineArray
Dim sCreatedby
Dim dCreatedDate, dReviewDate
Dim sREVIEWLIST, sFINALREVIEWLIST
Dim iRemindDays
Dim ctl As Control
Dim ffTemp As FormField
Set objwa = CreateObject("Word.application")
objwa.Visible = False
currpath = CurrentProject.Path & "\documents\current\"
currpath = Replace(currpath, "\\", "\")
sfilename = "Test_Draft.docx"
sfile = currpath & sfilename
Set objwd = objwa.Documents.Open(sfile)
For Each Shape In ActiveDocument.Shapes
sText = Shape.TextFrame.TextRange.Text
aLineArray = Split(sText, vbCr)
For i = 0 To UBound(aLineArray)
sLine = aLineArray(i)
If InStr(sLine, "Created") Then
sLine = Replace(sLine, vbTab, "")
sCreatedby = Mid(sLine, InStr(sLine, ":") + 1, InStrRev(sLine, "Date") - (InStr(sLine, ":") + 1))
dCreatedDate = Trim(Right(sLine, Len(sLine) - InStrRev(sLine, ":")))
If Not IsDate(dCreatedDate) Then sERR = sERR & "The Created Date is not a valid date" & vbCrLf
ElseIf InStr(sLine, "Reviewed by") Then
sREVIEWLIST = sLine
ElseIf InStr(sLine, "Final") Then
sFINALREVIEWLIST = sLine
ElseIf InStr(sLine, "remind") Then
sLine = Replace(Replace(sLine, vbTab, ""), " ", "")
dReviewDate = Mid(sLine, InStr(sLine, ":") + 1, InStr(sLine, "remind") - (InStr(sLine, ":") + 1))
If Not IsDate(dReviewDate) Then sERR = sERR & "The Review date is not a valid date" & vbCrLf
iRemindDays = Mid(sLine, InStr(sLine, "every") + 5, InStr(sLine, "day") - (InStr(sLine, "every") + 5))
If Not IsNumeric(iRemindDays) Then sERR = sERR & "The Number of days between reminders is not valid" & vbCrLf
If Len(sERR) = 0 Then
If DCount("*", "tblDocument", "[D_Name] = '" & sfilename & "' AND [D_Date] = #" & dCreatedDate & "#") > 0 Then
MsgBox "A file with the name: " & sfilename & vbCrLf & vbCrLf & "And a created date of: " & dCreatedDate & vbCrLf & vbCrLf & "Already exists", vbOKOnly, "ERROR Adding New File"
Exit Function
End If
sSQL = "INSERT INTO tblDocument (D_Name, D_Path, D_Createdby, D_Date, D_Date_Review, D_Reminder) VALUES ("
sSQL = sSQL & "'" & sfilename & "',"
sSQL = sSQL & "'" & currpath & "',"
sSQL = sSQL & "'" & sCreatedby & "',"
sSQL = sSQL & "#" & dCreatedDate & "#,"
sSQL = sSQL & "#" & dReviewDate & "#,"
sSQL = sSQL & iRemindDays & ")"
CurrentDb.Execute sSQL
sREVIEWLIST = Trim(Replace(sREVIEWLIST, vbTab, ""))
Else
MsgBox "The following errors were encountered attempting to import the information in this file" & vbCrLf & vbCrLf & sERR & vbCrLf & "Please review the following document and correct any problems" & vbCrLf & vbCrLf & sfile, vbOKOnly, "ERROR Importing File Information"
Exit Function
End If
End If
Next i
Set objwd = Nothing
Set objwa = Nothing
Exit Function
Next Shape
End Function