以下Microsoft Thechnet提供的VBA代码可保存电子邮件附件。
如果文件在另一个附件（通常是.msg附件）中，则脚本无法获取它们。
Public Function SaveAttachmentsFromSelection() As Long
Dim objFSO As Object ' Computer's file system object.
Dim objShell As Object ' Windows Shell application object.
Dim objFolder As Object ' The selected folder object from Browse for Folder dialog box.
Dim objItem As Object ' A specific member of a Collection object either by position or by key.
Dim selItems As Selection ' A collection of Outlook item objects in a folder.
Dim atmt As Attachment ' A document or link to a document contained in an Outlook item.
Dim strAtmtPath As String ' The full saving path of the attachment.
Dim strAtmtFullName As String ' The full name of an attachment.
Dim strAtmtName(1) As String ' strAtmtName(0): to save the name; strAtmtName(1): to save the file extension. They are separated by dot of an attachment file name.
Dim strAtmtNameTemp As String ' To save a temporary attachment file name.
Dim intDotPosition As Integer ' The dot position in an attachment name.
Dim atmts As Attachments ' A set of Attachment objects that represent the attachments in an Outlook item.
Dim lCountEachItem As Long ' The number of attachments in each Outlook item.
Dim lCountAllItems As Long ' The number of attachments in all Outlook items.
Dim strFolderPath As String ' The selected folder path.
Dim blnIsEnd As Boolean ' End all code execution.
Dim blnIsSave As Boolean ' Consider if it is need to save.
blnIsEnd = False
blnIsSave = False
lCountAllItems = 0
On Error Resume Next
Set selItems = ActiveExplorer.Selection
If Err.Number = 0 Then
' Get the handle of Outlook window.
lHwnd = FindWindow(olAppCLSN, vbNullString)
If lHwnd <> 0 Then
' /* Create a Shell application object to pop-up BrowseForFolder dialog box. */
Set objShell = CreateObject("Shell.Application")
Set objFSO = CreateObject("Scripting.FileSystemObject")
Set objFolder = objShell.BrowseForFolder(lHwnd, "Select folder to save attachments:", _
BIF_RETURNONLYFSDIRS + BIF_DONTGOBELOWDOMAIN, CSIDL_DESKTOP)
' /* Failed to create the Shell application. */
If Err.Number <> 0 Then
MsgBox "Run-time error '" & CStr(Err.Number) & " (0x" & CStr(Hex(Err.Number)) & ")':" & vbNewLine & _
Err.Description & ".", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
If objFolder Is Nothing Then
strFolderPath = ""
blnIsEnd = True
GoTo PROC_EXIT
Else
strFolderPath = CGPath(objFolder.Self.Path)
' /* Go through each item in the selection. */
For Each objItem In selItems
lCountEachItem = objItem.Attachments.Count
' /* If the current item contains attachments. */
If lCountEachItem > 0 Then
Set atmts = objItem.Attachments
' /* Go through each attachment in the current item. */
For Each atmt In atmts
' Get the full name of the current attachment.
strAtmtFullName = atmt.FileName
' Find the dot postion in atmtFullName.
intDotPosition = InStrRev(strAtmtFullName, ".")
' Get the name.
strAtmtName(0) = Left$(strAtmtFullName, intDotPosition - 1)
' Get the file extension.
strAtmtName(1) = Right$(strAtmtFullName, Len(strAtmtFullName) - intDotPosition)
' Get the full saving path of the current attachment.
strAtmtPath = strFolderPath & atmt.FileName
' /* If the length of the saving path is not larger than 260 characters.*/
If Len(strAtmtPath) <= MAX_PATH Then
' True: This attachment can be saved.
blnIsSave = True
' /* Loop until getting the file name which does not exist in the folder. */
Do While objFSO.FileExists(strAtmtPath)
strAtmtNameTemp = strAtmtName(0) & _
Format(Now, "_mmddhhmmss") & _
Format(Timer * 1000 Mod 1000, "000")
strAtmtPath = strFolderPath & strAtmtNameTemp & "." & strAtmtName(1)
' /* If the length of the saving path is over 260 characters.*/
If Len(strAtmtPath) > MAX_PATH Then
lCountEachItem = lCountEachItem - 1
' False: This attachment cannot be saved.
blnIsSave = False
Exit Do
End If
Loop
' /* Save the current attachment if it is a valid file name. */
If blnIsSave Then atmt.SaveAsFile strAtmtPath
Else
lCountEachItem = lCountEachItem - 1
End If
Next
End If
' Count the number of attachments in all Outlook items.
lCountAllItems = lCountAllItems + lCountEachItem
Next
End If
Else
MsgBox "Failed to get the handle of Outlook window!", vbCritical, "Error from Attachment Saver"
blnIsEnd = True
GoTo PROC_EXIT
End If
' /* For run-time error:
' The Explorer has been closed and cannot be used for further operations.
' Review your code and restart Outlook. */
Else
MsgBox "Please select an Outlook item at least.", vbExclamation, "Message from Attachment Saver"
blnIsEnd = True
End If
PROC_EXIT:
SaveAttachmentsFromSelection = lCountAllItems
' /* Release memory. */
If Not (objFSO Is Nothing) Then Set objFSO = Nothing
If Not (objItem Is Nothing) Then Set objItem = Nothing
If Not (selItems Is Nothing) Then Set selItems = Nothing
If Not (atmt Is Nothing) Then Set atmt = Nothing
If Not (atmts Is Nothing) Then Set atmts = Nothing
' /* End all code execution if the value of blnIsEnd is True. */
If blnIsEnd Then End
End Function
' #####################
' Convert general path.
' #####################
Public Function CGPath(ByVal Path As String) As String
If Right(Path, 1) <> "\" Then Path = Path & "\"
CGPath = Path
End Function
' ######################################
' Run this macro for saving attachments.
' ######################################
Public Sub ExecuteSaving()
Dim lNum As Long
lNum = SaveAttachmentsFromSelection
If lNum > 0 Then
MsgBox CStr(lNum) & " attachment(s) was(were) saved successfully.", vbInformation, "Message from Attachment Saver"
Else
MsgBox "No attachment(s) in the selected Outlook items.", vbInformation, "Message from Attachment Saver"
End If
End Sub
如果有带有附件的.msg附件，我该如何进行这项工作？
我找到了Rafa Vargas的VBScript。
'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 PDF 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!"
1-如何解压缩后删除.msg文件，如何确保它不会覆盖具有相同名称的文件？2-我可以从先前发布的VBA代码中调用脚本吗？
Outlook对象模型不提供任何用于开箱即用地打开附加项目的属性或方法。您需要将附加的消息保存到磁盘，然后通过调用Process.Run并将文件路径作为参数来打开它们。它们将在相同的Outlook实例（相同的进程）中打开，因为只有一个Outlook实例可以同时运行。 Outlook是一个单例。按照这种方式，您可以处理NewInspector和Activate事件，从中可以获得附件的副本并进一步处理附件。
我的技术与Eugene的技术略有不同。我不知道哪种方法更好，因此我将让您测试不同的方法。
我尚未尝试更新您的宏。相反，我创建了一个小宏来演示我的技术。 TestNewMacro是我的测试工具，SaveAttachmentsOfAttachedMsg是我的演示宏。
您允许用户选择附件的保存文件夹，我保存到了桌面。我将MSG附件保存在Window的临时文件夹中，并在提取附件后将其删除。 SaveAsFile将覆盖所有具有相同名称的现有文件，而不会发出警告。我没有提供代码来检查现有文件。我没有根据不需要的条件检查嵌套的MSG附件。任何签名或徽标将作为附件列出。我没有试图忽略它们。
Sub TestNewMacro()
' Skeleton for testing a new mail item processing macro using Inspector
' Replace statement marked ##### with call of new macro.
' Add code to create parameters for new test macro and remove any code to
' create parameters for old test macro.
Dim Exp As Explorer
Dim ItemCrnt As MailItem
Dim PathSave As String
' Technique for locating desktop from answer by Kyle:
' http://stackoverflow.com/a/17551579/973283
PathSave = CreateObject("WScript.Shell").specialfolders("Desktop")
Set Exp = Outlook.Application.ActiveExplorer
If Exp.Selection.Count = 0 Then
Call MsgBox("Please select one or more emails then try again", vbOKOnly)
Exit Sub
Else
For Each ItemCrnt In Exp.Selection
Call SaveAttachmentsOfAttachedMsg(ItemCrnt, PathSave) ' #####
Next
End If
End Sub
Sub SaveAttachmentsOfAttachedMsg(ByRef ItemCrnt As MailItem, ByVal PathSave As String)
' If ItemCrnt has a MSG attachment, save that attachment and then
' save any attachments of the MSG file.
' Requires reference to "Microsoft Scripting Runtime"
' A MSG attachment is saved in Window's temporary folder.
' The MSG file is opened and checked for attachments.
' Any attachments found are saved in folder PathSave. Warning: Files with
' the same name as the attachment will be overwritten without warning.
' The MSG attachment is deleted from Window's temporary folder.
Dim FileName As String
Dim Fso As New FileSystemObject
Dim InxA1 As Long
Dim InxA2 As Long
Dim ItemNew As MailItem
Dim PathFileMsg As String
Dim PathTemp As String
PathTemp = Fso.GetSpecialFolder(TemporaryFolder)
' Examine any attachments of ItemCrnt
For InxA1 = 1 To ItemCrnt.Attachments.Count
FileName = ItemCrnt.Attachments(InxA1).FileName
If LCase(Right$(FileName, 4)) = ".msg" Then
PathFileMsg = PathTemp & "\" & FileName
' Save MSG attachment to termporary folder
ItemCrnt.Attachments(InxA1).SaveAsFile PathFileMsg
' Open MSG file
Set ItemNew = Application.CreateItemFromTemplate(PathFileMsg)
' Examine any attachments of ItemNew
For InxA2 = 1 To ItemNew.Attachments.Count
FileName = ItemNew.Attachments(InxA2).FileName
' Save attachment of MSG attachment to save folder
ItemNew.Attachments(InxA2).SaveAsFile PathSave & "\" & FileName
Next
Set ItemNew = Nothing
' Delete MSG file
Kill PathFileMsg
End If
Next
Set Fso = Nothing
End Sub
OOM确实允许直接访问嵌入式邮件附件。在扩展MAPI级别（C ++或Delphi）上，您可以将附件打开为IMessage-IAttach::OpenProperty(PR_ATTACH_DATA_OBJ, IID_IMssage, ...)。
如果使用Redemption（任何语言，我是它的作者）是一个选项，它将在附件（EmbeddedMsg对象）上公开RDOAttachment属性。