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

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

 

代码如下：

Private Sub btnSaveAttachment_Click()Dim strnameDim wcountwcount = 0Dim savefolder'====对给定文件夹进行标准化=================If (Right(txtPath.Text, 1) <> "/") Then savefolder = txtPath.Text & "/"End IfIf ckWithDate.Value = True Then savefolder = txtPath.Text & Format(Date, "yyyymmdd") & "/"End IfDim fso, fSet fso = CreateObject("Scripting.FileSystemObject")'====建立文件夹=================If (fso.FolderExists(savefolder) = False) Then fso.CreateFolder (savefolder)End If On Error Resume NextDim myOlApp As New Outlook.ApplicationSet 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 IfFor 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 NextNext f.CloseEnd Sub