Append contents of .msg attachment to message body

I have a script to open attachments and append them to the message body. I have it working for text documents but I need it working for .msg attachments too.

At the moment it just doesn't read the object. Can anyone help?

Sub RunAScriptRuleRoutine(MyMail As MailItem)

Dim strID As String
Dim olNS As Outlook.NameSpace
Dim olMail As Outlook.MailItem
Dim olMailAT As Outlook.MailItem

strID = MyMail.EntryID
Set olNS = Application.GetNamespace("MAPI")
Set olMail = olNS.GetItemFromID(strID)

If olMail.Subject = "lala" Then

    If olMail.Attachments.Count > 0 Then

        Dim strLine As String
        Dim mailLine As String
        Dim strLine开发者_Python百科s As String

        For i = 1 To olMail.Attachments.Count

            strFileName = "C:\emailTemp\" + olMail.Attachments.Item(i).FileName

            If InStr(strFileName, "msg") Then

                olMail.Attachments.Item(i).SaveAsFile strFileName
                strLines = strLines + "//Start of " + strFileName + " //" + vbCrLf

                Open strFileName For Input As #1
                    Do While Not EOF(1)
                    Line Input #1, strLine
                        mailLine = mailLine + strLine
                    Loop
                Close #1

                olMailAT = mailLine
                strLine = objMailAT.Body
                strLines = strLines + "heres the .msg" + vbCrLf
                strLines = strLines + "//End of " + strFileName + " //" + vbCrLf

            Else

                olMail.Attachments.Item(i).SaveAsFile strFileName

                strLines = strLines + "//Start of " + strFileName + " //" + vbCrLf
                Open strFileName For Input As #1
                    Do While Not EOF(1)
                    Line Input #1, strLine
                        strLines = strLines + vbCrLf + strLine
                    Loop
                Close #1
                strLines = strLines + "//End of " + strFileName + " //" + vbCrLf

            End If

        Next

        'save to email body and save email
        olMail.Body = strLines
        olMail.Save

    End If

End If

Set olMail = Nothing
Set olNS = Nothing

End Sub

You should look into using Outlook Redemption.

Also, you should look at this documentation for format specificaion http://msdn.microsoft.com/en-us/library/cc463912.aspx

To read the contents of a .msg file, I have used the following approach.

1. Use CreateItemFromTemplate for the msg file using the Outlook object

2. Use this Outlook object to save the data into a .txt file

3. Once the .txt file is created, read it and use the data as required

Dim OL : Set OL=CreateObject("Outlook.Application")
Dim Msg ':Set Msg= CreateObject("Outlook.MailItem")
Set Msg = OL.CreateItemFromTemplate("C:\test.msg")
'MsgBox Msg.Subject
Msg.saveAs "C:\test.txt", olDoc
'The above statement will save the contents of .msg 
'file into the designate .txt file
Set OL = Nothing
Set Msg = Nothing 

Once the .txt file is created use it as required for your computations.

By the way...for a full solution see here... http://www.geakeit.co.uk/2010/06/25/automating-email-feedback-loop-fbl-processing-and-getting-around-aol%E2%80%99s-recipient-email-address-issue/

    Function GetCurrentItem() As Object
     Dim objApp As Outlook.Application
     Set objApp = Application
     On Error Resume Next
     Select Case TypeName(objApp.ActiveWindow)
     Case "Explorer"
     Set GetCurrentItem = _
     objApp.ActiveExplorer.Selection.Item(1)
     Case "Inspector"
     Set GetCurrentItem = _
     objApp.ActiveInspector.CurrentItem
     Case Else
     End Select
    End Function
 'This is how you read the attachment using your path "strFileName"
   Set OL = New Outlook.Application
   Set myMessage = OL.CreateItemFromTemplate(strFileName)
   myMessage.Display
   Set msg2 = GetCurrentItem()
   MsgBox(msg2.Body)
   mg2.Close 1