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

 在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