使用 VBA 从保存的 .msg 文件中提取附件

Extract attachments from saved .msg files using VBA

提问by Kyle Gorf

I am trying to extract attached Excel spreadsheets from saved Outlook messages. The messages have been saved into a shared folder as .msg files.

我正在尝试从保存的 Outlook 邮件中提取附加的 Excel 电子表格。消息已作为 .msg 文件保存到共享文件夹中。

I am struggling to get VBA to recognise the messages as files.

我正在努力让 VBA 将消息识别为文件。

I am trying to get the message details in the code below as a proof of concept.

我试图在下面的代码中获取消息详细信息作为概念证明。

Once I have this working I can work on looping through the files and dealing with the attachments.

一旦我完成这项工作，我就可以遍历文件并处理附件。

I have found code on this site for extracting attachments from emails still in Outlook but I do not have access to the Outlook folders and the original messages have been deleted.

我在此站点上找到了用于从仍在 Outlook 中的电子邮件中提取附件的代码，但我无权访问 Outlook 文件夹，并且原始邮件已被删除。

Sub ExtractExcel()
Dim aExcel As Outlook.Attachment
Dim stFilePath As String
Dim stFileName As String
Dim stAttName As String
Dim stSaveFolder As String
Dim oEmail As Outlook.MailItem

'~~> Outlook Variables for email
Dim eSender As String, dtRecvd As String, dtSent As String
Dim sSubj As String, sMsg As String

stFilePath = "Y:\Purchasing\The Team\User Name\Supply Chain Admin - Outlook\New-Revised Orders\FW  Mail Order Daffodil.msg"
stSaveFolder = "C:\Projects\SOTD\PO_Excel"

Debug.Print stFilePath
Debug.Print stSaveFolder

oEmail = stFilePath

With oEmail 
    eSender = oEmail.SenderEmailAddress
    dtRecvd = oEmail.ReceivedTime
    dtSent = oEmail.CreationTime
    sSubj = oEmail.Subject
    sMsg = oEmail.Body

    Debug.Print eSender
    Debug.Print dtRecvd
    Debug.Print dtSent
    Debug.Print sSubj
    Debug.Print sMsg
End With

End Sub

I'm using Excel VBA as I am familiar with it but am happy to have any alternative strategies suggested.

我正在使用 Excel VBA，因为我熟悉它，但很高兴能提出任何替代策略。

回答by brettdj

Using CreateItemFromTemplatefrom VBA Code to save an attachment (excel file) from an Outlook email that was inside another email as an attachmentyou could

使用CreateItemFromTemplate从VBA代码来保存从Outlook电子邮件，这是另一个电子邮件中作为附件附件（Excel文件）你可以

• open msgfiles from C:\temp\
• strip all attachments to C:\temp1\

• 从中打开msg文件C:\temp\
• 剥离所有附件 C:\temp1\

code

代码

Sub SaveOlAttachments()

Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String

    'path for creating msgs
strFilePath = "C:\temp\"
    'path for saving attachments
strAttPath = "C:\temp1\"

strFile = Dir(strFilePath & "*.msg")
Do While Len(strFile) > 0
    Set msg = Application.CreateItemFromTemplate(strFilePath & strFile)
    If msg.Attachments.Count > 0 Then
         For Each att In msg.Attachments
             att.SaveAsFile strAttPath & att.FileName
         Next
    End If
    strFile = Dir
Loop

End Sub

回答by Rafa Vargas

I have a VBS script that I use to extract all XLS* attachments form msg files saved in a folder. This script save the attachments in the same folder of msg files. I believe that can help you.

我有一个 VBS 脚本，用于从保存在文件夹中的 msg 文件中提取所有 XLS* 附件。此脚本将附件保存在 msg 文件的同一文件夹中。我相信可以帮到你。

Macro.vbs

宏.vbs

'Variables
Dim ol, fso, folderPath, destPath, f, msg, i
'Loading objects
Set ol  = CreateObject("Outlook.Application")
Set fso = CreateObject("Scripting.FileSystemObject")
'Setting MSG files path
folderPath = fso.GetParentFolderName(WScript.ScriptFullName)
'Setting destination path
destPath = folderPath   '* I am using the same 
WScript.Echo "==> "& folderPath
'Looping for files
For Each f In fso.GetFolder(folderPath).Files
    'Filtering only MSG files
    If LCase(fso.GetExtensionName(f)) = "msg" Then
        'Opening the file
        Set msg = ol.CreateItemFromTemplate(f.Path)
        'Checking if there are attachments
        If msg.Attachments.Count > 0 Then
            'Looping for attachments
            For i = 1 To msg.Attachments.Count
                'Checking if is a Excel file
                If LCase(Mid(msg.Attachments(i).FileName, InStrRev(msg.Attachments(i).FileName, ".") + 1 , 3)) = "xls" Then
                    WScript.Echo f.Name &" -> "& msg.Attachments(i).FileName
                    'Saving the attachment
                    msg.Attachments(i).SaveAsFile destPath &"\"& msg.Attachments(i).FileName
                End If
            Next
        End If
    End If
Next
MsgBox "Anexos extraidos com sucesso!"

To execute use "cscript c:\temp\msg_files\Macro.vbs" in command prompt.

要在命令提示符下执行使用“cscript c:\temp\msg_files\Macro.vbs”。

回答by Ankit Kulshrestha

I changed this code so that you can extract attachments from Excel instead of outlook.

我更改了此代码，以便您可以从 Excel 而不是 Outlook 中提取附件。

Don't forget to reference the Outlook Library, otherwise you will get the error

不要忘记引用 Outlook 库，否则会出现错误

Sub SaveOlAttachments()

Dim app As Outlook.Application
Dim msg As Outlook.MailItem
Dim att As Outlook.Attachment
Dim strFilePath As String
Dim strAttPath As String

Set app = New Outlook.Application

'path for creating msgs
strFilePath = "C:\Users\New folder\"

'path for saving attachments
strAttPath = "C:\Users\Extract\"

strFile = Dir(strFilePath & "*.msg")

Do While Len(strFile) > 0
    Set msg = app.CreateItemFromTemplate(strFilePath & strFile)
    If msg.Attachments.Count > 0 Then
         For Each att In msg.Attachments
             att.SaveAsFile strAttPath & att.Filename
         Next
    End If
    strFile = Dir
Loop

MsgBox "Task Completed", vbInformation

End Sub

回答by Dmitry Streblechenko

Use Namespace.OpenSharedItem. Do not use CreateItemFromTemplate- it wipes out many properties (such as sender and receiver related properties).

使用Namespace.OpenSharedItem. 不要使用CreateItemFromTemplate- 它会清除许多属性（例如发送者和接收者相关的属性）。