List of attachment in mail

[Dhavalshah]

Hi,

I have folder which contains mail (.msg) files. I want name of attachments, file type of attachments and hyperlinked name of mail file in which file is located and is it possible to extract file from such mail (.msg) files and transfer to save in selected folder.

[StuartR]

.msg is the format used by Microsoft Outlook for exporting emails and other content. You need to use Outlook to access the file contents. If you don't want to do this manually then it might be possible to automate it using VBA, so long as Microsoft Outlook is installed on your computer.

[Dhavalshah]

Microsoft Outlook is installed in my computer. How can I automate it by VBA?

[HansV]

See if this works for you. I haven't tested it myself for lack of .msg files.

Code: Select all

Sub ProcessMSG()
    ' Change paths but keep the trailing backslash \
    ' Path of the msg files
    Const sPath = "C:\Outlook\Messages\"
    ' Output path
    Const sTarget = "C:\Outlook\Attachments\"
    Dim sFile As String
    Dim objOL As Object ' Outlook.Application
    Dim objMsg As Object ' Outlook.MailItem
    Dim objAtt As Object ' Outlook.Attachment
    Dim f As Boolean
    Dim wsh As Worksheet
    Dim r As Long
    Dim sExt As String
    Application.ScreenUpdating = False
    Set wsh = Worksheets.Add
    wsh.Range("A1:C1").Value = Array("Attachment", "Type", "Path")
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        objOL.Session.Logon
        f = True
    End If
    On Error GoTo ErrHandler
    r = 1
    sFile = Dir(sPath & "*.msg")
    Do While sFile <> ""
        Set objMsg = objOL.Session.OpenSharedItem(sPath & sFile)
        For Each objAtt In objMsg.Attachments
            r = r + 1
            wsh.Range("A" & r).Value = objAtt.Filename
            sExt = LCase(Right(objAtt.Filename, InStrRev(objAtt.Filename, ".") + 1))
            Select Case sExt
                Case "doc", "docx", "docm"
                    wsh.Range("B" & r).Value = "Word Document"
                Case "xls", "xlsx", "xlsm", "xlsb"
                    wsh.Range("B" & r).Value = "Excel Workbook"
                Case "txt", "csv"
                    wsh.Range("B" & r).Value = "Text File"
                Case "gif", "png", "jpg"
                    wsh.Range("B" & r).Value = "Picture"
                Case Else
                    wsh.Range("B" & r).Value = "Other/Unknown"
            End Select
            objAtt.SaveAsFile sTarget & objAtt.Filename
            wsh.Hyperlinks.Add Anchor:=wsh.Range("C" & r), Address:=sTarget & objAtt.Filename
        Next objAtt
        objMsg.Close SaveMode:=1 ' olDiscard
        sFile = Dir
    Loop
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[Dhavalshah]

Hi,
It is working but not showing file type properly and I also want hyper link of mail file from which attachment is extracted.

Is it possible instead of fixing path in VBA I got a pop up which ask for Input path and output path.

[HansV]

New version (I don't know what to do about the file type):

Code: Select all

Sub ProcessMSG()
    Dim sPath As String
    Dim sTarget As String
    Dim sFile As String
    Dim objOL As Object ' Outlook.Application
    Dim objMsg As Object ' Outlook.MailItem
    Dim objAtt As Object ' Outlook.Attachment
    Dim f As Boolean
    Dim wsh As Worksheet
    Dim r As Long
    'Dim sExt As String
    With Application.FileDialog(4)
        .Title = "Select the folder with the .msg files"
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> "\" Then
                sPath = sPath & "\"
            End If
        Else
            Beep
            Exit Sub
        End If
        .Title = "Select the output folder"
        If .Show Then
            sTarget = .SelectedItems(1)
            If Right(sTarget, 1) <> "\" Then
                sTarget = sTarget & "\"
            End If
        Else
            Beep
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Set wsh = Worksheets.Add
    wsh.Range("A1:D1").Value = Array("Attachment", "Type", "Source Message", "Saved Attachment")
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        objOL.Session.Logon
        f = True
    End If
    On Error GoTo ErrHandler
    r = 1
    sFile = Dir(sPath & "*.msg")
    Do While sFile <> ""
        Set objMsg = objOL.Session.OpenSharedItem(sPath & sFile)
        For Each objAtt In objMsg.Attachments
            r = r + 1
            wsh.Range("A" & r).Value = objAtt.Filename
'            sExt = LCase(Right(objAtt.Filename, InStrRev(objAtt.Filename, ".") + 1))
'            Select Case sExt
'                Case "doc", "docx", "docm"
'                    wsh.Range("B" & r).Value = "Word Document"
'                Case "xls", "xlsx", "xlsm", "xlsb"
'                    wsh.Range("B" & r).Value = "Excel Workbook"
'                Case "txt", "csv"
'                    wsh.Range("B" & r).Value = "Text File"
'                Case "gif", "png", "jpg"
'                    wsh.Range("B" & r).Value = "Picture"
'                Case Else
'                    wsh.Range("B" & r).Value = "Other/Unknown"
'            End Select
            wsh.Range("B" & r).Value = "Unknown"
            objAtt.SaveAsFile sTarget & objAtt.Filename
            wsh.Hyperlinks.Add Anchor:=wsh.Range("C" & r), Address:=sPath & sFile
            wsh.Hyperlinks.Add Anchor:=wsh.Range("D" & r), Address:=sTarget & objAtt.Filename
        Next objAtt
        objMsg.Close SaveMode:=1 ' olDiscard
        sFile = Dir
    Loop
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[SpeakEasy]

>not showing file type properly

In what sense? Getting it wrong? Not displaying same types as file explorer? Not detailed enough? Not working at all?

[Dhavalshah]

Hi,
It is only extracting file from 1st outlook item of folder and not considering remaining outlook file in folder.

[HansV]

I have exported some messages with various attachments to .msg files. The following macro does exactly what you asked when I run it:

Code: Select all

Sub ProcessMSG()
    Dim sPath As String
    Dim sTarget As String
    Dim sFile As String
    Dim sFileName As String
    Dim sExt As String
    Dim objOL As Object ' Outlook.Application
    Dim objMsg As Object ' Outlook.MailItem
    Dim objAtt As Object ' Outlook.Attachment
    Dim f As Boolean
    Dim wsh As Worksheet
    Dim r As Long
    'Dim sExt As String
    With Application.FileDialog(4)
        .Title = "Select the folder with the .msg files"
        If .Show Then
            sPath = .SelectedItems(1)
            If Right(sPath, 1) <> "\" Then
                sPath = sPath & "\"
            End If
        Else
            Beep
            Exit Sub
        End If
        .Title = "Select the output folder"
        If .Show Then
            sTarget = .SelectedItems(1)
            If Right(sTarget, 1) <> "\" Then
                sTarget = sTarget & "\"
            End If
        Else
            Beep
            Exit Sub
        End If
    End With
    Application.ScreenUpdating = False
    Set wsh = Worksheets.Add
    wsh.Range("A1:D1").Value = Array("Attachment", "Type", "Source Message", "Saved Attachment")
    On Error Resume Next
    Set objOL = GetObject(Class:="Outlook.Application")
    If objOL Is Nothing Then
        Set objOL = CreateObject(Class:="Outlook.Application")
        objOL.Session.Logon
        f = True
    End If
    On Error GoTo ErrHandler
    r = 1
    sFile = Dir(sPath & "*.msg")
    Do While sFile <> ""
        Set objMsg = objOL.Session.OpenSharedItem(sPath & sFile)
        For Each objAtt In objMsg.Attachments
            r = r + 1
            sFileName = objAtt.Filename
            wsh.Range("A" & r).Value = sFileName
            sExt = LCase(Mid(sFileName, InStrRev(sFileName, ".") + 1))
            Select Case sExt
                Case "doc", "docx", "docm"
                    wsh.Range("B" & r).Value = "Word Document"
                Case "xls", "xlsx", "xlsm", "xlsb"
                    wsh.Range("B" & r).Value = "Excel Workbook"
                Case "txt", "csv"
                    wsh.Range("B" & r).Value = "Text File"
                Case "gif", "png", "jpg"
                    wsh.Range("B" & r).Value = "Picture"
                Case Else
                    wsh.Range("B" & r).Value = "Other/Unknown"
            End Select
            objAtt.SaveAsFile sTarget & objAtt.Filename
            wsh.Hyperlinks.Add Anchor:=wsh.Range("C" & r), Address:=sPath & sFile
            wsh.Hyperlinks.Add Anchor:=wsh.Range("D" & r), Address:=sTarget & objAtt.Filename
        Next objAtt
        objMsg.Close 1 ' olDiscard
        sFile = Dir
    Loop
    wsh.Range("A1:C1").EntireColumn.AutoFit
ExitHandler:
    On Error Resume Next
    If f Then
        objOL.Quit
    End If
    Application.ScreenUpdating = True
    Exit Sub
ErrHandler:
    MsgBox Err.Description, vbExclamation
    Resume ExitHandler
End Sub

[HansV]

Here is an example of the output (I removed the path for privacy reasons):

S1805.png