You cannot simply drop-in Excel code to Outlook - even if you could the message is not an Excel file.
As converting the code from my web site, to work with Word rather than Excel, may be a step too far for a novice coder, I have modified it for you. In order to produce the modification, I copied your message with the sample table to an e-mail message I could test.
This showed that the message when tested with the TestLines macro (from the web page, but included below) shows that the lines that represent the columns are two lines apart, thus if you have the first value (say Name) on line 1, the name AJHEZ is on line 3, so you need to add 2 when writing to the bookmark
e.g.
FillBM oDoc, "BMName", Trim(vText(i + 2))
The code example writes to two bookmarks BMName and BMDOB which must already be in the template document which is picked by name from the indicated folder on your desktop.
You can add other rows and bookmarks as required using similar syntax.
If the template is not present, where indicated, the process quits. If the bookmarks don't exist, they will not be written to ... obviously.
To test the code select an appropriate message and run the macro ProcessMsg
Note that if the offset is different for the actual message the results will not be correct, so use the macro to test as described on the web page.
Option Explicit
Sub ProcessMsg()
'Graham Mayor - http://www.gmayor.com
Dim olMsg As MailItem
On Error GoTo lbl_Exit
Set olMsg = ActiveExplorer.Selection.Item(1)
CopyToWord olMsg
lbl_Exit:
Exit Sub
End Sub
Sub CopyToWord(olItem As MailItem)
'Graham Mayor - http://www.gmayor.com
Dim wdApp As Object
Dim oDoc As Object
Dim vText As Variant
Dim sText As String
Dim i As Long
Dim bWdStarted As Boolean
Dim strPath As String
Const strTemplateName As String = "2016 Template (ER 21.06.2016).doc"
Dim fso As Object
strPath = Environ("USERPROFILE") & "\Desktop\Outlook\"
'Use FileExists function to determine the availability of the template
Set fso = CreateObject("Scripting.FileSystemObject")
If Not fso.FileExists(strPath & strTemplateName) Then GoTo lbl_Exit
'Get Word if it is running, or open it if not
On Error Resume Next
Set wdApp = GetObject(, "Word.Application")
If Err Then
Set wdApp = CreateObject("Word.Application")
bWdStarted = True
End If
wdApp.Visible = True
On Error GoTo 0
Set oDoc = wdApp.Documents.Add(strPath & strTemplateName)
'Process the message
With olItem
sText = olItem.Body
vText = Split(sText, Chr(13))
'Check each line of text in the message body
For i = UBound(vText) To 0 Step -1
If InStr(1, vText(i), "Name") > 0 Then
FillBM oDoc, "BMName", Trim(vText(i + 2))
End If
If InStr(1, vText(i), "Date of Birth") > 0 Then
FillBM oDoc, "BMDOB", Trim(vText(i + 2))
End If
Next i
'oDoc.Save
End With
lbl_Exit:
Set wdApp = Nothing
Set oDoc = Nothing
Set olItem = Nothing
Set fso = Nothing
Exit Sub
End Sub
Private Sub FillBM(oDoc As Object, strBMName As String, strValue As String)
'Graham Mayor - http://www.gmayor.com
Dim oRng As Object
With oDoc
On Error GoTo lbl_Exit
Set oRng = .Bookmarks(strBMName).Range
oRng.Text = strValue
oRng.Bookmarks.Add strBMName
End With
lbl_Exit:
Set oRng = Nothing
Exit Sub
End Sub
Sub TestLines()
'Graham Mayor - http://www.gmayor.com
Dim olItem As Outlook.MailItem
Dim vText() As String
Dim sText As String
Dim i As Long
For Each olItem In Application.ActiveExplorer.Selection
sText = Replace(olItem.Body, Chr(160), Chr(32))
vText = Split(sText, Chr(13))
For i = 0 To UBound(vText)
sText = "Line " & i & vbCr & vText(i)
If i < UBound(vText) - 1 Then
sText = sText & vbCr & _
"Line " & i + 1 & vbCr & vText(i + 1)
End If
If i < UBound(vText) - 2 Then
sText = sText & vbCr & _
"Line " & i + 2 & vbCr & vText(i + 2)
End If
If MsgBox(sText, vbOKCancel) = vbCancel Then Exit Sub
Next i
Next olItem
lbl_Exit:
Set olItem = Nothing
Exit Sub
End Sub
Reply With Quote
