Opening Outlook Emails From Excel And Checking For Attachments\Embedded Items

[JimHol]

Hi All!

I have an Excel that contains the drive locations of saved out Outlook emails. From here I need to open each email, check it for attachments, as well as, files embedded within the body of the email. I can do most of the code I just need help with the following:

1) Open the email located in "cells("A",2).value"

2) Check the email for file attachments.

3) Check the body of the email for embedded objects.

Any and all help greatly appreciated!

Thanks,
Jim

 

[John_w]

Try this as a start. It works with Outlook message format files (.msg files):

Public Sub Outlook_Msg()

    Dim outApp As Outlook.Application
    Dim outEmail As Outlook.MailItem
    Dim outAttachment As Outlook.Attachment
    Dim saveInFolder As String
    
    saveInFolder = "C:\folder\path\"   'CHANGE THIS
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    
    On Error Resume Next
    Set outApp = GetObject(, "Outlook.Application")
    If outApp Is Nothing Then
        MsgBox "Outlook is not open"
        Exit Sub
    End If
    On Error GoTo 0
    
    Set outEmail = outApp.CreateItemFromTemplate(Range("A2").Value)
    
    For Each outAttachment In outEmail.Attachments
        outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
    Next
    
End Sub

Needs a reference to MS Outlook Object library.

 

[JimHol]

John,

Thanks for your reply! I am getting a "Type Mismatch Error" on the "CreateItemFromTemplate" statement. Can you spot what I am doing wrong?

    Dim outApp As Outlook.Application
    Dim outEmail As Outlook.MailItem
    Dim outAttachment As Outlook.Attachment
    Dim saveInFolder As String
   
    Dim PresPath As String, relativePath As String, ThisFile As String

    Dim a As Long, b As Long, c As Long, d As Long, e As Long, f As Long, g As Long, h As Long, i As Long, jt As Long, x As Long, y As Long
        
    ThisFile = ThisRecord(0)
    a = ThisRecord(1)
    b = ThisRecord(2)
    c = ThisRecord(3)
    d = ThisRecord(4)
    e = ThisRecord(5)
    f = ThisRecord(6)
    g = ThisRecord(7)
    h = ThisRecord(8)
    i = ThisRecord(9)
    jt = ThisRecord(10)
    x = ThisRecord(11)
    y = ThisRecord(12)
    ThisEditSheet = ThisRecord(13)
    CellContents = ThisRecord(14)
    targetpath = ThisRecord(15)
    ProjectName = ThisRecord(16)
    DiscoveryJobName = ThisRecord(17)
    ThisTab = ThisRecord(18)
    ThisCheck = ThisRecord(19)
    
    saveInFolder = "C:\temp\"
    If Right(saveInFolder, 1) <> "\" Then saveInFolder = saveInFolder & "\"
    
    Set outApp = GetObject(, "Outlook.Application")
    Set outEmail = outApp.CreateItemFromTemplate(ThisFile)
    
    NumberOfAttachments = outEmail.Attachments.Count
    
    For Each outAttachment In outEmail.Attachments
        outAttachment.SaveAsFile saveInFolder & outAttachment.Filename
    Next

 

[John_w]

Try replacing that line with:

    Set outEmail = outApp.Session.OpenSharedItem(Range("A2").Value)

I've read that CreateItemFromTemplate opens a .msg file from disk in Outlook 2003, and OpenSharedItem works for 2007 (and higher?).

 

[JimHol]

John,

I am using Outlook 2007. I made the suggested changes but I am still getting a "Runtime Error 14 Type mismatch" on that line. Any ideas what maybe causing this problem? I do have the Microsoft Outlook Library referenced in VBA.

Thanks,
Jim

 

[John_w]

What is in cell A2 of the active sheet? It should be the full path and file name of an Outlook .msg file, because you said:

1) Open the email located in "cells("A",2).value"

For example, C:\folder\path\An Outlook email.msg

 

[JimHol]

I actually pasted the full path directly into the code. If I past it into the run command the email does open fine.

 

[John_w]

I am referring to my code - a simple test example.

For your code, what is the value of ThisFile at the CreateItemFromTemplate line (or the OpenSharedItem line)? From the code you've posted it appears to be empty (undefined), which explains the error.

 

[JimHol]

[TABLE="width: 145"]
<colgroup><col width="145"></colgroup><tbody>[TR]
[TD="class: xl63, width: 145"]Ok, I found the problem. It seams to be in the network path. The email below generates the error from the network location but works fine if i copy it to my local drive. Any ideas?

\\VECTOR03\ESI01\My Email\PR000004\Discovery Jobs\DJ000081\e-Mail\146000\145110\000000004A768C52CFFBC84D9AA3C7FC5E6328E084B63000.msg
[/TD]
[/TR]
</tbody>[/TABLE]

 

[John_w]

I tried my code with a .msg file in a network location and it worked successfully. I don't know why yours produces that error.

One solution is for the code to first copy the .msg file from the network location to your local drive using the FileCopy statement, for example:

    Dim networkFile As String
    networkFile = "\\VECTOR03\ESI01\My Email\PR000004\Discovery Jobs\DJ000081\e-Mail\146000\145110\000000004A768C52CFFBC84D9AA3C7FC5E6328E084B63000.msg"
    FileCopy networkFile, ThisWorkbook.Path & Mid(networkFile, InStrRev(networkFile, "\"))

which copies the .msg file to the same folder as the workbook.