Outlook question .msg attachment [Resolved]

I have an email with 97 attachments...
I have code to loop through and save all of them..
But, I just realized these attachments are .msg files
and What I need is the .LOG file INSIDE each attachment.
Grab the msg attachment.. open it and Save the LOG file inside each one?


C'mon RobDog888 I bet you can do this one...

I'm back now. :D

97 attached msg files and each one has 1 or more attached files? :eek:

yes.. most likely each msg has 1 attahcment (Server logs)

I need each file out of each msg!
cant get it to work!!!

Yes, it does seem that this will require a little more effort. I'll see what I can come up with. :D

I hope I didnt take too long. Had something to take care of.

Here is the working demo. It will .Find the message with the subject you specify. Then it will save the first attached message to the
filesystem as a .msg file. The I create a new object based upon the .msg file and grab the file attached to it and save it to the file
system and delete the .msg file. So your left with 97 text files or log files. You are going to want to add some error trapping to
make sure the the log attachment file exists and if the message exists as an attachment and if the main email has the
attachmetns, etc.

Basically its the working logic and mechanics.


VB/Outlook Guru™ :D

VB Code:

Option Explicit
'Add a reference to MS Outlook xx.0 Object Library
Private Sub Command1_Click()
    Dim oApp As Outlook.Application
    Dim oNS As Outlook.NameSpace
    Dim oFolder As Outlook.MAPIFolder
    Dim oEmail As Outlook.MailItem
    Dim oMsg As Outlook.MailItem
    Dim oAttachs As Outlook.Attachments
    Dim oAttach As Outlook.Attachment
    Dim i As Integer
    
    Set oApp = New Outlook.Application
    Set oNS = oApp.GetNamespace("MAPI")
    Set oFolder = oNS.GetDefaultFolder(olFolderInbox)
    Set oEmail = oFolder.Items.Find("[Subject] = '97 Messages'")
    If Not oEmail Is Nothing Then
        Set oAttachs = oEmail.Attachments
        For i = 1 To oAttachs.Count
            Set oAttach = oAttachs.Item(i)
            oAttach.SaveAsFile ("C:\Item[" & i & "].msg")
            Set oMsg = oApp.CreateItemFromTemplate("C:\Item[" & i & "].msg")
            oMsg.Attachments.Item(1).SaveAsFile ("C:\Item[" & i & "].log")
            Kill "C:\Item[" & i & "].msg"
            Set oMsg = Nothing
            Set oAttach = Nothing
        Next
    Else
        MsgBox "Couldnt find your massive email!"
    End If
    Set oAttachs = Nothing
    Set oEmail = Nothing
    Set oFolder = Nothing
    Set oNS = Nothing
    oApp.Quit
    Set oApp = Nothing
End Sub

You are Awsome Rob!
If I ever get out to LA or you ever get to Rochester.. I owe you a beer (or 12) for all the times you have helped.. Thanks

the peice I was missing was the
Set oMsg = oApp.CreateItemFromTemplate("C:\Item[" & i & "].msg")
could not figure out how to "hit" that saved file....

works like a charm...
(FYI to make this fun project even worse.. I had to open every LOG file and strip the data out / put it in excel / and format it!...had all that already...)

This Thread gets a bg "DONE" stamp

Talk about a fun project :rolleyes: (except for the Outlook part :D). Glad I was able to help. I have been away from doing Outlook
projects for a while (burnout) but I am getting back into it in anticipation of Office 12, late 2006.

This place just hooked me up big-time so I have to say thanks. I had a client that got a slew of bounced-back emails from a mass mailing she did. I had to extract the email addresses that got bounced back. She forwarded me the bounce-backs in batches of roughly 100 attached emails per email (that is one email contained roughly 100 bounce-back email attachments). There were 17 batches (roughly 1700 bounce-backs). No, she's not a spammer. She's a job placement recruiter. But I digress. I needed the email addresses from the attached email's attached email. Here is the code I ended up using. It's not pretty but it gets the job done. I can't wait for MicroSoft to include an implicit conversion from Attachment to MailItem. Then all this wouldn't be necessary...

Without further ado:

Code:

---

Sub GetApplicableEmails()
    On Error GoTo errorhandler
    Dim m As Object, x As Long, a As Attachment
    x = 1
    For Each m In Application.GetNamespace("MAPI").Folders("Personal Folders").Folders("Inbox").Items
        If m.Class = 43 Then
            If UCase(m.SenderEmailAddress) = UCase("<client's email address>") Then
                If ((InStr(UCase(m.subject), UCase("mail")) > 0) And (InStr(UCase(m.subject), UCase("failure")) > 0)) Then
                    For Each a In m.Attachments
                        If Right(UCase(a.FileName), 3) = "MSG" Then
                            a.SaveAsFile "C:\MailItems From <client's name>\Item[" & x & "].msg"
                            x = x + 1
                        End If
                    Next a
                End If
            End If
        End If
    Next m
   
   
    For x = 1 To 10000
        If Dir("C:\MailItems From <client's name>\Item[" & x & "].msg") <> "" Then
            Set m = Application.CreateItemFromTemplate("C:\MailItems From <client's name>\Item[" & x & "].msg", Application.GetNamespace("MAPI").Folders("Personal Folders").Folders("Inbox").Folders("<client's name>"))
            m.Save
            Kill "C:\MailItems From <client's name>\Item[" & x & "].msg"
        Else
            Exit For
        End If
    Next x
   
    x = 1
    For Each m In Application.GetNamespace("MAPI").Folders("Personal Folders").Folders("Drafts").Items
        If m.Class = 43 Then
            For Each a In m.Attachments
                If Right(UCase(a.FileName), 3) = "MSG" Then
                    a.SaveAsFile "C:\MailItems From <client's name>\Item[" & x & "].msg"
                    x = x + 1
                End If
            Next a
            m.Delete
        End If
    Next m
   
    For x = 1 To 10000
        If Dir("C:\MailItems From <client's name>\Item[" & x & "].msg") <> "" Then
            Set m = Application.CreateItemFromTemplate("C:\MailItems From <client's name>\Item[" & x & "].msg", Application.GetNamespace("MAPI").Folders("Personal Folders").Folders("Inbox").Folders("<client's name>"))
            m.Save
            Kill "C:\MailItems From <client's name>\Item[" & x & "].msg"
        Else
            Exit For
        End If
    Next x
   
    ExtractInvalidEmailAddresses
   
    Set a = Nothing
    Set m = Nothing
    Exit Sub
errorhandler:
    Debug.Print "ERROR " & Err.Number
    Debug.Print "Description: " & Err.Description
    Stop
    Resume Next
End Sub
Sub ExtractInvalidEmailAddresses()
    On Error GoTo ErrHandler
    Dim m As Object, oFldr As MAPIFolder, f As Integer, r As Recipient
    Dim c As ADODB.Connection, x As Integer, yn As Integer, blnDelete As Boolean

    Set oFldr = Application.GetNamespace("MAPI").PickFolder
   
    yn = MsgBox("Delete applicable emails in '" & oFldr.Name & "' once processed?", vbYesNoCancel, "Confirm Post Processing Deletion")
    Select Case yn
        Case Is = vbYes
            blnDelete = True
        Case Is = vbNo
            blnDelete = False
        Case Else
            GoTo ExitSub
    End Select
    If Not oFldr Is Nothing Then
        Set c = New ADODB.Connection
        c.Open "Driver={Microsoft Access Driver (*.mdb)};Dbq=C:\MailItems From <client's name>\<client's name>BadEmailAddresses.mdb;"
        For Each m In oFldr.Items
            If m.Class = olMail Then
                For Each r In m.Recipients
                    c.Execute "INSERT INTO BAD_ADDRESSES VALUES('" & r.Address & "')"
                Next r
            End If
            If blnDelete Then m.Delete
        Next m
        c.Close
        MsgBox "Done!"
    End If

    Set c = Nothing
    Set m = Nothing
    Set oFldr = Nothing
   
   
ExitSub:
    Exit Sub
   
ErrHandler:
    If c.Errors.Count > 0 Then
        For x = 0 To (c.Errors.Count - 1)
            If c.Errors(x).NativeError <> -1605 Then
                MsgBox c.Errors(x).Description, vbMsgBoxHelpButton, "ADODB COnnection Error#: " & c.Errors(x).NativeError, c.Errors(x).HelpFile, c.Errors(x).HelpContext
                Stop
            Else
                If x = (c.Errors.Count - 1) Then
                    c.Errors.Clear
                    Debug.Print "Duplicate Address: " & r.Address
                    Resume Next
                Else
                    MsgBox c.Errors(x).Description, vbMsgBoxHelpButton, "ADODB COnnection Error#: " & c.Errors(x).NativeError, c.Errors(x).HelpFile, c.Errors(x).HelpContext
                    Stop
                    c.Errors.Clear
                End If
            End If
        Next x
    Else
        MsgBox Err.Description, vbMsgBoxHelpButton, "Error Number: " & Err.Number, Err.HelpFile, Err.HelpContext
    End If
End Sub

---

Feel free to clean it, reproduce it, streamline it, bag on it, claim it as your own, edit it, etc.:D