Export text in an email to excel

  • Thread starter Thread starter Guest
  • Start date Start date
G

Guest

Hi There

I have a html form on our intranet site that when filled in sends me an
email in the following format:

name=Jamie
[email protected]
comment=Help
sex=female
etc

The subject is always the same. Is it possible to create a macro that will
automatically export just the answers into an excel spreadsheet. It will
obviously have to paste the information on the next available row.

I am completely new to VBA so dont have any idea where to start.

Any help would be greatly appreciated.

Thanks in advance

Jamie
 
Run this macro with your e-mail open and see if it does the trick. I wrote
it using Outlook 2003 and Excel 2003.

Sub ExportMessageBodyValuePairsToExcel()
On Error Resume Next

'Must have the e-mail in question open
'Ensure that you have set a reference to the Microsoft Excel X.0 Object Model
Dim objMail As Outlook.MailItem
Dim objWkb As Excel.Workbook, objWks As Excel.Worksheet
Dim objExcel As Excel.Application
Dim intX As Integer, intY As Integer
Dim intCnt As Integer, intUBound As Integer, intLastIndex As Integer
Dim strX As String
Dim varVals() As String, strValues() As String

If ActiveInspector Is Nothing Then Exit Sub 'No open e-mail
If ActiveInspector.CurrentItem.Class <> olmail Then Exit Sub 'only work
with e-mail items
Set objMail = ActiveInspector.CurrentItem

'Look for line-break characters
intX = InStr(intX + 1, objMail.Body, Chr(13), vbTextCompare)
Do
If intCnt = 0 Then
strX = Mid(objMail.Body, intLastIndex + 1, intX - intLastIndex -
1)
Else
strX = Mid(objMail.Body, intLastIndex + 2, intX - intLastIndex -
2)
End If
intLastIndex = intX '+ 1
varVals = Split(strX, "=", , vbTextCompare)
'Should get a one dimensional array with two values
intUBound = UBound(varVals)
If Err.Number = 0 Then
If UBound(varVals) = 1 Then
ReDim Preserve strValues(1, intCnt)
strValues(0, intCnt) = varVals(0)
strValues(1, intCnt) = varVals(1)
intCnt = intCnt + 1 'increment value pair count
Else
'Not a value pair; ignore
End If
End If
intX = InStr(intX + 1, objMail.Body, Chr(13), vbTextCompare)
Loop While intX <> 0

Set objExcel = New Excel.Application
Set objWkb = objExcel.Workbooks.Add
Set objWks = objExcel.ActiveSheet
objExcel.Visible = True

'Populate cells
For intX = 0 To 1
For intY = 0 To UBound(strValues, 2)
objWks.Cells(intX + 1, intY + 1) = strValues(intX, intY)
Next
Next
Set objWks = Nothing
Set objExcel = Nothing
Set objWkb = Nothing
Set objMail = Nothing
End Sub
 
Back
Top