Vba 将Outlook文件夹中的所有电子邮件附件保存到Windows文件夹
我有大约80封电子邮件,都带有附件,我想把它们保存到硬盘上的文件夹中 如何使用脚本完成此操作?请看这里: 请看这里:Vba 将Outlook文件夹中的所有电子邮件附件保存到Windows文件夹,vba,outlook,email-attachments,Vba,Outlook,Email Attachments,我有大约80封电子邮件,都带有附件,我想把它们保存到硬盘上的文件夹中 如何使用脚本完成此操作?请看这里: 请看这里: 此子例程将在用户指定的Outlook文件夹中找到的所有附件保存到文件系统上用户指定的目录中。它还使用指向已清除文件的链接更新每条消息 它还包含额外的注释,以帮助突出显示.Delete方法将如何收缩附件容器,并在注释中动态搜索~~ 此宏仅在Outlook 2010上测试 ' ------------------------------------------------------
此子例程将在用户指定的Outlook文件夹中找到的所有附件保存到文件系统上用户指定的目录中。它还使用指向已清除文件的链接更新每条消息 它还包含额外的注释,以帮助突出显示.Delete方法将如何收缩附件容器,并在注释中动态搜索~~ 此宏仅在Outlook 2010上测试
' ------------------------------------------------------------
' Requires the following references:
'
' Visual Basic for Applications
' Microsoft Outlook 14.0 Object Library
' OLE Automation
' Microsoft Office 14.0 Object Library
' Microsoft Shell Controls and Automation
' ------------------------------------------------------------
Public Sub SaveOLFolderAttachments()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim sSavePathFS As String
Dim sDelAtts
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each loops will not work.
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0
' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior.
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted.
msg.Save
End If
Next
End Sub
此子例程将在用户指定的Outlook文件夹中找到的所有附件保存到文件系统上用户指定的目录中。它还使用指向已清除文件的链接更新每条消息 它还包含额外的注释,以帮助突出显示.Delete方法将如何收缩附件容器,并在注释中动态搜索~~ 此宏仅在Outlook 2010上测试
' ------------------------------------------------------------
' Requires the following references:
'
' Visual Basic for Applications
' Microsoft Outlook 14.0 Object Library
' OLE Automation
' Microsoft Office 14.0 Object Library
' Microsoft Shell Controls and Automation
' ------------------------------------------------------------
Public Sub SaveOLFolderAttachments()
' Ask the user to select a file system folder for saving the attachments
Dim oShell As Object
Set oShell = CreateObject("Shell.Application")
Dim fsSaveFolder As Object
Set fsSaveFolder = oShell.BrowseForFolder(0, "Please Select a Save Folder:", 1)
If fsSaveFolder Is Nothing Then Exit Sub
' Note: BrowseForFolder doesn't add a trailing slash
' Ask the user to select an Outlook folder to process
Dim olPurgeFolder As Outlook.MAPIFolder
Set olPurgeFolder = Outlook.GetNamespace("MAPI").PickFolder
If olPurgeFolder Is Nothing Then Exit Sub
' Iteration variables
Dim msg As Outlook.MailItem
Dim att As Outlook.attachment
Dim sSavePathFS As String
Dim sDelAtts
For Each msg In olPurgeFolder.Items
sDelAtts = ""
' We check each msg for attachments as opposed to using .Restrict("[Attachment] > 0")
' on our olPurgeFolder.Items collection. The collection returned by the Restrict method
' will be dynamically updated each time we remove an attachment. Each update will
' reindex the collection. As a result, it does not provide a reliable means for iteration.
' This is why the For Each loops will not work.
If msg.Attachments.Count > 0 Then
' This While loop is controlled via the .Delete method
' which will decrement msg.Attachments.Count by one each time.
While msg.Attachments.Count > 0
' Save the file
sSavePathFS = fsSaveFolder.Self.Path & "\" & msg.Attachments(1).FileName
msg.Attachments(1).SaveAsFile sSavePathFS
' Build up a string to denote the file system save path(s)
' Format the string according to the msg.BodyFormat.
If msg.BodyFormat <> olFormatHTML Then
sDelAtts = sDelAtts & vbCrLf & "<file://" & sSavePathFS & ">"
Else
sDelAtts = sDelAtts & "<br>" & "<a href='file://" & sSavePathFS & "'>" & sSavePathFS & "</a>"
End If
' Delete the current attachment. We use a "1" here instead of an "i"
' because the .Delete method will shrink the size of the msg.Attachments
' collection for us. Use some well placed Debug.Print statements to see
' the behavior.
msg.Attachments(1).Delete
Wend
' Modify the body of the msg to show the file system location of
' the deleted attachments.
If msg.BodyFormat <> olFormatHTML Then
msg.Body = msg.Body & vbCrLf & vbCrLf & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts
Else
msg.HTMLBody = msg.HTMLBody & "<p></p><p>" & "Attachments Deleted: " & Date & " " & Time & vbCrLf & vbCrLf & "Saved To: " & vbCrLf & sDelAtts & "</p>"
End If
' Save the edits to the msg. If you forget this line, the attachments will not be deleted.
msg.Save
End If
Next
End Sub
这是正确的,只要复制粘贴即可。它花了一段时间才完成一个包含20多条消息的文件夹。但是上面的另一个没有完全起作用。这在Windows 10上的Msn邮件应用程序能起作用吗?这一个只需复制粘贴即可。它花了一段时间才完成一个包含20多条消息的文件夹。但是上面的另一个应用程序不能完全工作。在Windows 10上,Msn邮件应用程序能正常工作吗?这个应用程序不能完全工作。也许,它太慢了,我无法观察到它对所有选择都有效。它确实可以选择一条消息。这条消息没有完全起作用。也许,它太慢了,我无法观察到它对所有选择都有效。它确实可以选择一条消息。