Private
oVars As Variables
Private vVar As
Variant
'This macro requires a
reference to the Microsoft Outlook Object Library
Sub ProcessFormAttachments()
Dim i As
Long
Dim olApp As
Outlook.Application
Dim olNs As
Outlook.Namespace
Dim olFolder As
Outlook.Folder
Dim olItem As
Outlook.MailItem
Dim olMailItem As
Outlook.MailItem
Dim oNewMailItem As
Outlook.MailItem
Dim olAttachments As
Outlook.Attachments
Dim sFname As String
Dim sPath As String
Dim iMessages As Long
Dim TempDoc As
Document
'Set the temporary document
path
sPath = "D:\My Documents\Test\Temp\"
On Error Resume Next
'Open Outlook
Set olApp
= GetObject(, "Outlook.Application")
If Err = 429
Then
'Outlook is closed so start Outlook
Set olApp =
CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")
'Locate the folder containing the unprocessed e-mail messages
Set olFolder =
olNs.GetDefaultFolder(olFolderInbox).Folders("Forms_In")
'Examine each message starting from the bottom of the list
For i = olFolder.Items.Count
To 1 Step -1
Set olItem = olFolder.Items(i)
'Mark the message as read
olItem.UnRead =
False
Set olAttachments = olItem.Attachments
'Count the attachments attached to the message
If olAttachments.Count = 1 Then
'There is one
attachment so note its filename
sFname = olAttachments.Item(1).DisplayName
On Error Resume Next
'If the filename
already exists in the temporary folder, remove it.
Kill sPath & sFname
On Error GoTo 0
'Save the
attachment to the temporary folder
olAttachments.Item(1).SaveAsFile _
sPath & sFname
Else
'The message has the wrong number of attachments
'Mark it as unread
olItem.UnRead = True
'and move it to
the Forms_Wrong folder
olItem.Move olFolder.Folders("Forms_Wrong")
'and move on to the next message
GoTo ProcessNext
End If
'Open the
temporary document from its folder
'The form may contain automacros, not required
'by this macro, so
first disable them
WordBasic.DisableAutoMacros 1
Set TempDoc = Documents.Open(sPath & sFname)
Set oVars = TempDoc.Variables
'Store the sender's e-mail address and message
subject in the document
oVars("varSender").Value = olItem.SenderEmailAddress
oVars("varSubject").Value = olItem.Subject
'Word 2007 has a habit of switching to draft view
so select PrintView
ActiveWindow.View.Type = wdPrintView
'Check all the form fields in the temporary
document
For j = 1 To
TempDoc.FormFields.Count
'If any are incomplete
If TempDoc.FormFields(j).Result = ""
Then
'Call the
routine to return the unaltered form to the sender
Call ReturnForm
'close the temporary document
TempDoc.Close wdDoNotSaveChanges
'and move it to the Forms_Incomplete folder
olItem.Move olFolder.Folders("Forms_Incomplete")
'and quit the loop
Exit For
Else
'The form is correctly filled, so call the routine
'to
extract the data to a table.
Call ExtractDataFromForm
'Alternatively call the routine to save to a comma
delimited text file
'Call ExtractDataFromForm2
'Or if the form contains content controls rather than legacy form fields
'Call ExtractFataFromForm3
'Close the temporary document
TempDoc.Close wdDoNotSaveChanges
'and move the message to the Forms_Complete folder
olItem.Move olFolder.Folders("Forms_Completed")
Exit For
End If
Next j
ProcessNext:
Next i
'Re-enable automacros
WordBasic.DisableAutoMacros
0
'Clean up
Set olItem = Nothing
Set olFolder =
Nothing
Set olAttachments =
Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
'Routine to return the incorrectly filled form to the sender
Sub ReturnForm()
'This macro requires a
reference to the Microsoft Outlook Object Library
Dim oOutlookApp As Outlook.Application
Dim oItem As
Outlook.MailItem
On Error Resume Next
Set oVars = ActiveDocument.Variables
'Outlook is already running so open it.
Set oOutlookApp = GetObject(, "Outlook.Application")
'Create a new e-mail message
Set oItem =
oOutlookApp.CreateItem(olMailItem)
With oItem
'Read the sender and subject from the document
variables
.To =
oVars("varSender")
.Subject = "Re: " &
oVars("varSubject")
'Add a suitable message c/w your contact details
.Body = "The form you
have submitted is incomplete." & vbCr & _
"Please complete the form and return it." & vbCr & vbCr & _
oOutlookApp.Session.CurrentUser.name & vbCr & _
oOutlookApp.Session.CurrentUser.Address
.Attachments.Add
Source:=ActiveDocument.FullName, _
Type:=olByValue,
DisplayName:="Document as attachment"
.Send
'Send the message (It might be better to ensure
that Outlook
'does
not send the messages immediately while testing).
End With
'Clean up
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub
'Routine to extract data from the correctly submitted forms to a Word
table
Sub ExtractDataFromForm()
Dim oDoc As
Word.Document
Dim oTarget As
Word.Document
Dim oTable As
Table
Dim iCol As Integer
Dim i As Long
Dim sText As String
Dim sName As String
Dim fName As String
'Define the name and path of the document to hold the data
'This can be Word 2007 docx format if preferred.
fName = "D:\My Documents\FormData.doc"
Set oDoc = ActiveDocument
On Error Resume Next
'Open the data document to receive input
Set oTarget = Documents.Open(fName)
If Err.Number = 5174
Then
'The data document doesn't exist so create a new one
Set oTarget =
Documents.Add
oTarget.SaveAs fName
End If
Set oFld = oDoc.FormFields
'Count the form fields in the document
iCol = oFld.Count
If oTarget.Tables.Count = 0
Then
'It's a new
data document so if there are more than 10 fields,
'set the new layout in landscape mode, and add a 2 row table.
If iCol > 10
Then
oTarget.PageSetup.Orientation = _
wdOrientLandscape
End If
oTarget.Tables.Add
oTarget.Range, 2, iCol
Else
'It's an existing table so add
a single row
oTarget.Tables(1).Rows.Add
End If
Set oTable = oTarget.Tables(1)
'If
an incorrect form has slipped through with the wrong number of
'form fields, the routine quits with an error message
If iCol <> oTable.Columns.Count
Then
MsgBox "The form and
data table do not have the same number of fields", _
vbCritical, "Error!"
Exit Sub
End If
'Read the form data
For i = 1 To
iCol
sName = oFld(i).name
Select Case oFld(i).Type
Case Is = wdFieldFormDropDown, wdFieldFormTextInput
sText =
oFld(i).Result
Case Is = wdFieldFormCheckBox
sText =
oFld(i).CheckBox.Value
End Select
'If it is a new
table add the field names to the header row
If
oTable.Rows.Count = 2 Then
With oTable.Cell(1, i).Range
.Text = sName
.Font.Bold = True
.Collapse wdCollapseEnd
End With
End If
'Write the form
data to the table
With oTable.Cell(oTable.Rows.Count,
i).Range
.Text = sText
.Collapse wdCollapseEnd
End With
Next i
End Sub
'Alternative routine to save the form data as a comma delimited file
Sub ExtractDataFromForm2()
Dim oTarget As
Document
Dim oDoc As
Document
Dim fName As String
Set oDoc = ActiveDocument
'Define the name and
path of the text file to hold the data
fName = "D:\My
Documents\FormData.txt"
'Turn off screen updating to
reduce flicker whilst opening/closing files
Application.ScreenUpdating = False
On Error Resume Next
Set oTarget = Documents.Open(fName,
False)
If Err.Number = 5174
Then
'The file does not exist, so create a new one
Set oTarget = Documents.Add
'and add the header row comprising the form field
names
For i = 1 To oDoc.FormFields.Count
oTarget.Range.InsertAfter Chr(34) & _
oDoc.FormFields(i).name & Chr(34)
If i < oDoc.FormFields.Count Then
oTarget.Range.InsertAfter Chr(44)
End If
If i = oDoc.FormFields.Count Then
oTarget.Range.InsertAfter vbCr
End If
Next i
'and save it as a text file
oTarget.SaveAs fName,
wdFormatText
End If
'Add the form field content to the text file
For i = 1 To
oDoc.FormFields.Count
oTarget.Range.InsertAfter Chr(34) & _
oDoc.FormFields(i).Result
& Chr(34)
If i < oDoc.FormFields.Count Then
oTarget.Range.InsertAfter Chr(44) & Chr(32)
End If
If i =
oDoc.FormFields.Count Then
oTarget.Range.InsertAfter vbCr
End If
Next i
'Save the data
file
oTarget.Save
'Restore screen updating
Application.ScreenUpdating = True
End Sub
