As indicated I have been amusing myself over the weekend with a process that
may be of interest to you.
It works on the premise that you receive completed forms by e-mail and that
the messages are processed by an Outlook rule to move the incoming forms
directly to an Outlook Inbox sub folder called "Forms_In" (which should have
three sub folders "Forms_Completed", "Forms_Incomplete" and "Forms_Wrong").
You will need to create these folders and the Outlook rule.
The main macro, run from Word, looks at each message in the "Forms_In"
folder to establish whether it has a single attachment. Messages that have
no attachment (or more than one attachment) are moved to the "Forms_Wrong"
folder so that you can establish whether they are legitimately connected
with the return of forms and process them manually according to what you
find.
Messages that have the required single attachment are processed as forms.If
any of the fields are incomplete, the message is moved to the
"Forms_Incomplete" folder and the submitted form is returned to the sender
with a note inviting the sender to complete it correctly.
Messages that have correctly filled forms are processed to extract the data
from the form to a document containing a Word table. If that document
doesn't exist, it is created.
Within those guidelines the macros do as I have suggested, but this is just
a rough draft and a basis for further development to suit your particular
requirement.
Note that you will need to set a reference to Outlook in the Word VBA tools
> references and change the two document paths sPath and fName to reflect
your own path structure.
http://www.gmayor.com/installing_macro.htm
It doesn't resolve your original dilemma of getting users to run macros to
validate the forms before submitting them, but it cuts down the work when
incorrectly filled forms are supplied.
The macro only checks for incomplete field entry. It doesn't check whether
the completed data is correct.
Private oVars As Variables
Private vVar As Variant
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
sPath = "D:\My Documents\Test\Temp\"
On Error Resume Next
Set olApp = GetObject(, "Outlook.Application")
If Err = 429 Then
Set olApp = CreateObject("Outlook.Application")
End If
Set olNs = olApp.GetNamespace("MAPI")
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders("Forms_In")
For i = olFolder.Items.Count To 1 Step -1
Set olItem = olFolder.Items(i)
Set olAttachments = olItem.Attachments
If olAttachments.Count = 1 Then
sFname = olAttachments.Item(1).DisplayName
On Error Resume Next
Kill sPath & sFname
On Error GoTo 0
olAttachments.Item(1).SaveAsFile _
sPath & sFname
Else
'MsgBox "Message has " & olAttachments.Count & " attachments!"
olItem.Move olFolder.Folders("Forms_Wrong")
GoTo ProcessNext
End If
Set TempDoc = Documents.Open(sPath & sFname)
Set oVars = TempDoc.Variables
oVars("varSender").Value = olItem.SenderEmailAddress
oVars("varSubject").Value = olItem.Subject
ActiveWindow.View.Type = wdPrintView
For j = 1 To TempDoc.FormFields.Count
If TempDoc.FormFields(j).Result = "" Then
'MsgBox "Incomplete form"
Call ReturnForm
TempDoc.Close wdDoNotSaveChanges
olItem.Move olFolder.Folders("Forms_Incomplete")
Exit For
Else
'MsgBox "Form OK"
Call ExtractDataFromForm
TempDoc.Close wdDoNotSaveChanges
olItem.Move olFolder.Folders("Forms_Completed")
Exit For
End If
Next j
ProcessNext:
Next i
olItem.UnRead = False
Set olItem = Nothing
Set olFolder = Nothing
Set olAttachments = Nothing
Set olNs = Nothing
Set olApp = Nothing
End Sub
Sub ReturnForm()
Dim bStarted As Boolean
Dim oOutlookApp As Outlook.Application
Dim oItem As Outlook.MailItem
On Error Resume Next
Set oVars = ActiveDocument.Variables
Set oOutlookApp = GetObject(, "Outlook.Application")
If Err <> 0 Then
Set oOutlookApp = CreateObject("Outlook.Application")
bStarted = True
End If
Set oItem = oOutlookApp.CreateItem(olMailItem)
With oItem
.to = oVars("varSender")
.Subject = "Re: " & oVars("varSubject")
.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
End With
Set oItem = Nothing
Set oOutlookApp = Nothing
End Sub
Sub ExtractDataFromForm()
Dim oDoc As Word.Document
Dim oTarget As Word.Document
Dim oTable As Table
Dim iCol As Integer
Dim iRows As Integer
Dim i As Long
Dim sText As String
Dim sName As String
Dim fName As String
Dim sCancel As String
fName = "D:\My Documents\FormData.doc"
Set oDoc = ActiveDocument
On Error Resume Next
Set oTarget = Documents.Open(fName)
If Err.Number = 5174 Then
Set oTarget = Documents.Add
oTarget.SaveAs fName
End If
Set oFld = oDoc.FormFields
iCol = oFld.Count
If oTarget.Tables.Count = 0 Then
If iCol > 10 Then
oTarget.PageSetup.Orientation = _
wdOrientLandscape
End If
oTarget.Tables.Add oTarget.Range, 2, iCol
Else
oTarget.Tables(1).Rows.Add
End If
Set oTable = oTarget.Tables(1)
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
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 oTable.Rows.Count = 2 Then
With oTable.Cell(1, i).Range
.Text = sName
.Font.Bold = True
.Collapse wdCollapseEnd
End With
End If
With oTable.Cell(oTable.Rows.Count, i).Range
.Text = sText
.Collapse wdCollapseEnd
End With
Next i
End Sub
--
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
Graham Mayor - Word MVP
My web sitewww.gmayor.com
Word MVP web sitehttp://word.mvps.org
<>>< ><<> ><<> <>>< ><<> <>>< <>><<>
