Export Outlook message to excel using code

[Raynepau49]

Could anyone please help

I have found some code to transfer part of the contents of a template style outlook message to specific cells in an excell spreadsheet and it is / was working really well. I have placed a sample of the email and the code here.

A sample of the email is as follows;

01. Date of thie report: 13/12/12
02. Date of Incident: 12/12/12

The code is as follows

Option Explicit

Sub CopyToExcel()
Dim xlApp As Excel.Application
Dim xlWB As Excel.Workbook
Dim xlSheet As Excel.Worksheet
Dim olItem As Outlook.MailItem
Dim vText As Variant
Dim sText As String
Dim vItem As Variant
Dim oRng As Range
Dim i As Long
Dim rCount As Long
Dim bXStarted As Boolean
Const strPath As String = "C:\Users\Paul\Documents\Test.xlsx" 'the path of the workbook

If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox "No Items selected!", vbCritical, "Error"
Exit Sub
End If
On Error Resume Next
Set xlApp = GetObject(, "Excel.Application")
If Err <> 0 Then
Application.StatusBar = "Please wait while Excel source is opened ... "
Set xlApp = CreateObject("Excel.Application")
bXStarted = True
End If
On Error GoTo 0
'Open the workbook to input the data
Set xlWB = xlApp.Workbooks.Open(strPath)
Set xlSheet = xlWB.Sheets("Sheet1")

'Process each selected record
For Each olItem In Application.ActiveExplorer.Selection
sText = olItem.Body
vText = Split(sText, Chr(13))
'Find the next empty line of the worksheet
rCount = xlSheet.Range("B" & xlSheet.Rows.Count).End(xlUp).Row
rCount = rCount + 1

'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "01. Date of this report:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "02. Date of Incident:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If

Next i
xlWB.Save
Next olItem
xlWB.Close SaveChanges:=True
If bXStarted Then
xlApp.Quit
End If
Set xlApp = Nothing
Set xlWB = Nothing
Set xlSheet = Nothing
Set olItem = Nothing
End Sub


However I have now been asked to change the email by placing an excel template in the body of the email with the same questions. I have tried to attach a sample but cannot seem to make it work and now I realise I am a serious technophobe !!

Hopefully this makes sense

The body of the email goes something like this
Column 1 Column 2 Column 3
1 Date of this report 13/12/12
2 Date of Incident 12/12/12

If all this makes sense, the last thing to mention is that now I have an excel template in the body of the email I cannot get the code to work and I assume it is the part of code that needs to be changed which is pasted below


'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "01. Date of this report:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("A" & rCount) = Trim(vItem(1))
End If

If InStr(1, vText(i), "02. Date of Incident:") > 0 Then
vItem = Split(vText(i), Chr(58))
xlSheet.Range("B" & rCount) = Trim(vItem(1))
End If

Many thanks

 

[kjv1611]

I'm not 100% sure I follow where everything is in this equation. Please verify this:

1. Where is the data when you first find it (So, where are you initially pulling the data from?)
2. Where is the data going?

At first, you said, it's in Outlook, going to Excel. Then you said (it sounds like), it's in Excel going to Outlook.... or is it Outlook going to an Excel Workbook embedded within another Outlook email message???

Surely the data source is not Outlook, but rather the communications medium.

Please lay out where the data comes from - the initial source, or as close to the initial source as you can get, and where is it going? I think I get that you're currently sending it as text in an email message, but it's desired to have the values entered into a spreadsheet instead, and then that spreadsheet included as an attachment.


"But thanks be to God, which giveth us the victory through our Lord Jesus Christ." 1 Corinthians 15:57

 

[Raynepau49]

Thank you for your help. I have finally found another solution / approach

 

[SkipVought]

Raynepau49,

Tek-Tips is a site for communicating information, which is how we receive information.

So it is customary and polite to post the solution you found for the benefit of others who may be interested and seeking information. It works well that way.

Skip,

_{Just traded in my old subtlety...
for a NUANCE!}