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

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

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

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

一旦我有了这个工作，我就可以在文件中循环并处理附件

我在此网站上找到了从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

---

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

使用

CreateItemFromTemplate

，您可以

• 从

  C:\temp\

• 删除

  C:\temp1\

代码

---

使用

名称空间.OpenSharedItem

。不要使用

CreateItemFromTemplate

-它会清除许多属性（例如与发送方和接收方相关的属性）。

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

宏.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!"

---

要执行，请在命令提示符下使用“cscript c:\temp\msg\u files\Macro.vbs”。

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

别忘了引用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

---

您看过来自的CreateItemFromTemplate吗？谢谢您的帮助。我在Set msg行上遇到一个错误：运行时错误438“对象不支持此属性或方法”修复了它！在Outlook中而不是Excel中运行了代码，该代码已运行。非常感谢您的帮助：-）您可以从Excel运行它。（1） 引用outlook对象库（2）将

Dim app添加为outlook。应用程序
添加到您的声明中（3）使用“app”而不是“Application”。如果OP想要删除附件，则不确定为什么会出现此问题？如果阅读此线程的其他人想要提取附件以外的属性，则这将是一个问题。
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