保存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