vba腳本從Outlook保存所有附件（PDF）然後刪除電子郵件

Question

我有一堆文件，我每天都會掃描並保存。我使用的掃描儀機器以PDF格式將掃描後的文件發送到我的收件箱，然後我打開電子郵件，保存PDF文件，並刪除電子郵件，我重複這個操作幾百次，如果我將它節省了很多時間可以自動執行此過程。

所以我在尋找一個VBA腳本爲Outlook即會

1. 保存在我的收件箱的文件夾中的所有附加的PDF文件，然後
2. 刪除電子郵件。

我已經看到了很多的貼子在網上，解決類似的腳本，但迄今爲止我見過的一切只會做了手術的第一部分，做同樣的事情，也不會成爲PDF的工作。

在做了一些搜索之後，我在網上發現了一些代碼，它與我正在尋找的代碼類似。我調整它到我想要它做的，並想出了這個：

Sub getAttachmentsAndDelete() 

Dim olFolder As Outlook.MAPIFolder 
Dim msg As Outlook.MailItem 
Dim msg2 As Outlook.MailItem 
Dim att As Outlook.Attachment 
Dim strFilePath As String 
Dim strTmpMsg As String 
Dim fsSaveFolder As String 

fsSaveFolder = "C:\Users\MikeJones\Documents\Scanned\" 

'path for creating attachment msg file for stripping 
strFilePath = "C:\Users\MikeJones\Documents\Scanned\temp" 
strTmpMsg = "KillMe.msg" 

'My testing done in Outlok using a "temp" folder underneath Inbox 
Set olFolder = 
Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
Set olFolder = olFolder.Folders("scanned") 

If olFolder Is Nothing Then Exit Sub 


For Each msg In olFolder.Items 

    If msg.Attachments.Count > 0 Then 

     While msg.Attachments.Count > 0 
      bflag = False 
      If Right$(msg.Attachments(1).FileName, 3) = "msg" Then 
       bflag = True 
       msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg 
       Set msg2 = Application.CreateItemFromTemplate(strFilePath & 
        strTmpMsg) 
      End If 

      If bflag Then 
       msg2.Attachments(1).SaveAsFile fsSaveFolder & 
       msg2.Attachments(1).FileName 
       msg2.Delete 
      Else 
       sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName 
       msg.Attachments(1).SaveAsFile sSavePathFS 
      End If 

      msg.Attachments(1).Delete 

     Wend 

     msg.Delete 
    End If 

Next 

End Sub 

這是有點古怪，但完成工作。我遇到的唯一問題是它一次只能提取幾個電子郵件/文件，所以我重複了幾次循環，現在一次點擊就能處理大約150封電子郵件。

Answer 1

在做了一些搜索之後，我在網上發現了一些類似於我正在尋找的代碼。我把它適用於我想要它做的事，並與此想出了：

Sub getAttachmentsAndDelete() 

Dim olFolder As Outlook.MAPIFolder 
Dim msg As Outlook.MailItem 
Dim att As Outlook.Attachment 
Dim sSavePath, sSaveFolder As String 

sSaveFolder = "C:\Users\JohnDoe\Documents\Scanned\" 

Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
Set olFolder = olFolder.Folders("scanned") 
If olFolder Is Nothing Then Exit Sub 

For i = olFolder.Items.Count To 1 Step -1 
     Set msg = olFolder.Items(i) 
     If msg.Attachments.Count > 0 Then 
      For j = msg.Attachments.Count To 1 Step -1 
       sSavePath = (sSaveFolder & msg.Attachments(j).FileName) 
       msg.Attachments(j).SaveAsFile sSavePath 
      Next 
     End If 
    msg.Delete 
Next 

End Sub 

這個宏從得到的消息中的附件我的Outlook文件夾中的收件箱\掃描並保存到文檔\我的硬盤驅動器上掃描。

*編輯2017年11月：感謝niton指出我的解決方案存在缺陷，並建議使用For循環而不是For Each循環。我在這裏重構了我的算法並清理了代碼。此解決方案不再檢查消息中的附件，但在一封電子郵件中檢查多個附件，這正是我想要的。

Answer 2

對於您的方案，處理郵件附件時沒有意義。

Sub getAttachmentsAndDelete() 

Dim olFolder As Outlook.MAPIFolder 
Dim msg As Outlook.MailItem 
'Dim msg2 As Outlook.MailItem 
'Dim att As Outlook.Attachment 
Dim strFilePath As String 
'Dim strTmpMsg As String 
Dim fsSaveFolder As String 

fsSaveFolder = "C:\Users\MikeJones\Documents\Scanned\" 

'path for creating attachment msg file for stripping 
'strFilePath = "C:\Users\MikeJones\Documents\Scanned\temp" 
'strTmpMsg = "KillMe.msg" 

'My testing done in Outlok using a "temp" folder underneath Inbox 
Set olFolder = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox) 
Set olFolder = olFolder.Folders("scanned") 

If olFolder Is Nothing Then Exit Sub 

For Each msg In olFolder.Items 

    If msg.Attachments.Count > 0 Then 

     While msg.Attachments.Count > 0 

      'bflag = False 
      ' If Right$(msg.Attachments(1).FileName, 3) = "msg" Then 
      ' bflag = True 
      ' msg.Attachments(1).SaveAsFile strFilePath & strTmpMsg 
      ' Set msg2 = Application.CreateItemFromTemplate(strFilePath & 
      '  strTmpMsg) 
      ' End If 

      ' If bflag Then 
      ' msg2.Attachments(1).SaveAsFile fsSaveFolder & 
      ' msg2.Attachments(1).FileName 
      ' msg2.Delete 
      ' Else 

      ' ** Save any attachment pdf or otherwise ** 
       sSavePathFS = fsSaveFolder & msg.Attachments(1).FileName 
       msg.Attachments(1).SaveAsFile sSavePathFS 
      ' End If 

      ' Deleted attachments cannot be recovered. 
      ' Only do so if it is necessary. 
      ' Here there is no difference 
      ' waiting until the entire message is deleted 
      ' msg.Attachments(1).Delete 

     Wend 

     msg.Delete 
    End If 

Next 

End Sub 

Re：重複循環。

For Each msg In olFolder.Items是一個正向計數循環。您正在刪除郵件。隨着所有剩餘的物品向上移動，您可以跳過循環認爲剛處理過的物品。這使得每次都有一半的項目未處理。刪除或移動時，使用反向計數循環。

For i = olFolder.Items.count to 1 step -1 
    Set msg = olFolder.Items(i) 
    If msg.Attachments.Count > 0 

或處理第一個項目，直到零項仍然如While Wend循環中所示。