Sub NewHTMLMessage()
Dim MyMail As MailItem
Set MyMail = CreateItem(olMailItem)
With MyMail
.HTMLBody = HTMLFormData
.Subject = "Your outbound subject here"
.To = "Someone@Somewhere.com"
'Saving the message in Development, change to Send in production
.Save
End With
Set MyMail = Nothing
End Sub
Function HTMLFormData() As String
Dim intFile As Integer
Dim strTemplateName As String
intFile = FreeFile
'This is the loaction of the template file
strTemplateName = "C:\FormTemplate.htm"
Open strTemplateName For Input As #intFile
HTMLFormData = Input(LOF(intFile), #intFile)
Close #intFile
End Function<HTML>
<BODY>
<FORM method="post" action="mailto:YourName@YourCompany.com?subject=Your Inbound Subject here" enctype="text/plain">
<INPUT TYPE="hidden" NAME="internalsubject" VALUE="hidden submit"><P>
Question 1:<P>
<INPUT TYPE=Radio Name=Question1 Value=1>One
<INPUT TYPE=Radio Name=Question1 Value=2>Two
<INPUT TYPE=Radio Name=Question1 Value=3>Three
<INPUT TYPE=Radio Name=Question1 Value=4>Four
<INPUT TYPE=Radio Name=Question1 Value=5>Five<P>
Question 2:<P>
<INPUT TYPE=Radio Name=Question2 Value=1>One
<INPUT TYPE=Radio Name=Question2 Value=2>Two
<INPUT TYPE=Radio Name=Question2 Value=3>Three
<INPUT TYPE=Radio Name=Question2 Value=4>Four
<INPUT TYPE=Radio Name=Question2 Value=5>Five<P>
(rest of form content)<P>
<INPUT Type=Submit VALUE=Respond>
</FORM>
</BODY>
</HTML>CautionMP said:
Sub SingleSurveyExport()
'This is the text of Subject line from the survey email
Const SurveySubject As String = "Survey Response"
'This is filename that the results are output to
Const OutputFileName As String = "C:\" & SurveySubject & ".csv"
Dim MyExplorer As Explorer
Dim MyMailItem As MailItem
Dim blnWriteHeader As Boolean
Dim strOutput As String
Set MyExplorer = ActiveExplorer
If MyExplorer.Selection.Item(1).Class = olMail Then
Set MyMailItem = MyExplorer.Selection.Item(1)
If MyMailItem.Subject = SurveySubject Then
'Check to see if output file exists
If Dir(OutputFileName) = "" Then
blnWriteHeader = True
End If
If blnWriteHeader Then
'The file did not exist so create the header row and file
strOutput = Chr(34) & "SenderName" & Chr(34) & "," & _
Chr(34) & "SentOn" & Chr(34) & "," & _
ParseSurveyBody(MyMailItem.Body, True)
AppendSurveyResults OutputFileName, strOutput
blnWriteHeader = False
End If
'Now write the data from the email
'The next two lines grab information from the email
strOutput = Chr(34) & MyMailItem.SenderName & Chr(34) & ","
strOutput = strOutput & Chr(34) & MyMailItem.SentOn & Chr(34) & ","
'This calls the function that converts the body to a CSV record
strOutput = strOutput & ParseSurveyBody(MyMailItem.Body, False)
'This will output to the file
AppendSurveyResults OutputFileName, strOutput
End If
End If
Set MyMailItem = Nothing
Set MyExplorer = Nothing
End Sub
Public Sub BatchSurveyExport()
'This is the text of Subject line from the survey email
Const SurveySubject As String = "Survey Response"
'This is filename that the results are output to
Const OutputFileName As String = "C:\" & SurveySubject & ".csv"
Dim MyNameSpace As NameSpace
Dim MyInbox As MAPIFolder
Dim MyMailItem As MailItem
Dim blnWriteHeader As Boolean
Dim strOutput As String
'Check to see if output file exists
If Dir(OutputFileName) = "" Then
blnWriteHeader = True
End If
Set MyNameSpace = GetNamespace("MAPI")
Set MyInbox = MyNameSpace.GetDefaultFolder(olFolderInbox)
For Each MyMailItem In MyInbox.Items
If MyMailItem.Subject = SurveySubject Then
If blnWriteHeader Then
'The file did not exist so create the header row and file
strOutput = Chr(34) & "SenderName" & Chr(34) & "," & _
Chr(34) & "SentOn" & Chr(34) & "," & _
ParseSurveyBody(MyMailItem.Body, True)
AppendSurveyResults OutputFileName, strOutput
blnWriteHeader = False
End If
'Now write the data from the email
'The next two lines grab information from the email
strOutput = Chr(34) & MyMailItem.SenderName & Chr(34) & ","
strOutput = strOutput & Chr(34) & MyMailItem.SentOn & Chr(34) & ","
'This calls the function that converts the body to a CSV record
strOutput = strOutput & ParseSurveyBody(MyMailItem.Body, False)
'This will output to the file
AppendSurveyResults OutputFileName, strOutput
End If
Next MyMailItem
Clean_Up:
Set MyMailItem = Nothing
Set MyInbox = Nothing
Set MyNameSpace = Nothing
End SubPublic Function ParseSurveyBody(BodyText As String, GetHeader As Boolean) As String
Dim lngField As Long
Dim strFields() As String, strField() As String
Dim strOutput As String
'The text in the body is Carriage Return/Line Feed delimited so split
'to get each field
strFields = Split(BodyText, vbCrLf)
For lngField = 0 To UBound(strFields)
'Make sure the field has data
If strFields(lngField) <> "" Then
'The field name and value are seperated by '=' so split
strField = Split(strFields(lngField), "=")
If GetHeader Then
'Calling routine wants the header row 0
strOutput = strOutput & Chr(34) & strField(0) & Chr(34) & ","
Else
strOutput = strOutput & Chr(34) & strField(1) & Chr(34) & ","
End If
Else
'IF it's not the last field write a place holder
If lngField <> UBound(strFields) Then
strOutput = strOutput & Chr(34) & Chr(34) & ","
End If
End If
Next lngField
ParseSurveyBody = strOutput
End Function
Sub AppendSurveyResults(FullFileName As String, CSVRecordInfo As String)
Dim intOutputFile As Integer
intOutputFile = FreeFile
Open FullFileName For Append As #intOutputFile
Print #intOutputFile, CSVRecordInfo
Close #intOutputFile
End Sub
