保存outlook指定文件夹下附件（VBA）

最新推荐文章于 2022-03-31 22:33:01 发布

iwteih

最新推荐文章于 2022-03-31 22:33:01 发布

阅读量7.2k

点赞数 2

CC 4.0 BY-SA版权

分类专栏：杂项文章标签： vba basic date each

本文链接：https://blog.youkuaiyun.com/iwteih/article/details/4511217

杂项专栏收录该内容

0 篇文章

订阅专栏

本文介绍了一种使用VBA脚本在Outlook中批量导出邮件附件的方法。该脚本能够遍历指定文件夹内的所有邮件，并将每封邮件中的附件保存到本地指定路径下。如果附件已存在，则会在文件名后追加日期时间戳避免覆盖。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

在outlook里Visual Basic 编辑器里，添加一下窗口，如图：

代码如下：

Private Sub btnSaveAttachment_Click() Dim strname Dim wcount wcount = 0 Dim savefolder '====对给定文件夹进行标准化================= If (Right(txtPath.Text, 1) <> "/") Then savefolder = txtPath.Text & "/" End If If ckWithDate.Value = True Then savefolder = txtPath.Text & Format(Date, "yyyymmdd") & "/" End If Dim fso, f Set fso = CreateObject("Scripting.FileSystemObject") '====建立文件夹================= If (fso.FolderExists(savefolder) = False) Then fso.CreateFolder (savefolder) End If On Error Resume Next Dim myOlApp As New Outlook.Application Set myNamespace = myOlApp.GetNamespace("MAPI") If (txtOutlookPath.Text = myNamespace.GetDefaultFolder(olFolderInbox).Name) Then Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox) Else Set myFolder = myNamespace.GetDefaultFolder(olFolderInbox).Folders(txtOutlookPath.Text) End If For i = 1 To myFolder.Items.Count '====获得每个邮件item================= Set mymailitem = myFolder.Items(i) For Each Attachment In mymailitem.Attachments '====判断文件存在否，不存在就覆盖，否则跳过================= If (fso.FileExists(savefolder & Attachment.DisplayName) = False) Then Attachment.SaveAsFile savefolder & Attachment.DisplayName Else MyArray = Split(Attachment.DisplayName, ".", -1, 1) Attachment.SaveAsFile savefolder & MyArray(0) & Format(mymailitem.ReceivedTime, "_yyyymmdd_hhnn") & "." & MyArray(1) End If wcount = wcount + 1 Next Next f.Close End Sub