VBA Outlook - 自动运行收件箱中的所有电子邮件？

Question

我有以下代码，我正在使用它将电子邮件附件保存到文件夹中。我希望每次打开outlook并在我的[email protected]收件箱（非默认收件箱）中检查所有电子邮件时，这个vba会自动运行。

目前虽然它只检查在活动收件箱中选择的电子邮件。有人可以告诉我如何编辑我的代码，让它做我需要的。谢谢

Public Sub SaveAttachments() 
    Dim objOL As Outlook.Application 
    Dim objMsg As Outlook.MailItem 'Object 
    Dim objAttachments As Outlook.Attachments 
    Dim objSelection As Outlook.Selection 
    Dim i As Long 
    Dim lngCount As Long 
    Dim strFile As String 
    Dim strFolderPath As String 
    Dim strDeletedFiles As String 
    Dim withParts As String 
    Dim withoutParts As String 


     ' Get the path to your My Documents folder 
     On Error Resume Next 

     ' Instantiate an Outlook Application object. 
     Set objOL = CreateObject("Outlook.Application") 

     ' Get the collection of selected objects. 
     Set objSelection = objOL.ActiveExplorer.Selection 

    ' The attachment folder needs to exist 
    ' You can change this to another folder name of your choice 


     ' Set the Attachment folder. 
     strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" 

     ' Check each selected item for attachments. 

     For Each objMsg In objSelection 

     Set objAttachments = objMsg.Attachments 
     lngCount = objAttachments.Count 
     If lngCount > 0 Then 

     ' Use a count down loop for removing items 
     ' from a collection. Otherwise, the loop counter gets 
     ' confused and only every other item is removed. 

     For i = lngCount To 1 Step -1 

     ' Get the file name. 
     strFile = objAttachments.item(i).FileName 
     If Right(strFile, 3) = "pdf" Then 

     ' Combine with the path to the Temp folder. 
     withParts = strFile 
     withoutParts = Replace(withParts, ".pdf", "") 

     strFile = strFolderPath & withoutParts & "\" & strFile 

     ' Save the attachment as a file. 
     objAttachments.item(i).SaveAsFile strFile 

    End If 
     Next i 
     End If 


     Next 

    ExitSub: 

    Set objAttachments = Nothing 
    Set objMsg = Nothing 
    Set objSelection = Nothing 
    Set objOL = Nothing 
    End Sub 

Answer 1

只需要编辑一些行。将类似objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("[email protected]")的文件用于收件箱文件夹相同级别的文件夹。下面是修改代码：

Public Sub SaveAttachments() 
    Dim objOL As Outlook.Application 
    Dim objMsg As Outlook.MailItem 'Object 
    Dim objAttachments As Outlook.Attachments 
    Dim objSelection As Outlook.Selection 
    Dim i As Long 
    Dim lngCount As Long 
    Dim strFile As String 
    Dim strFolderPath As String 
    Dim strDeletedFiles As String 
    Dim withParts As String 
    Dim withoutParts As String 


     ' Get the path to your My Documents folder 
     On Error Resume Next 

     ' Instantiate an Outlook Application object. 
     Set objOL = CreateObject("Outlook.Application") 

     ' Get the collection of selected objects. 
     'Set objSelection = objOL.ActiveExplorer.Selection 
     'Istead set this to the selected objects you just need to set to your email folder 

     'This is for a inbox same level folder 
     Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("[email protected]") 

     'This is for a folder inside the inbox folder 
     'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("[email protected]") 

    ' The attachment folder needs to exist 
    ' You can change this to another folder name of your choice 


     ' Set the Attachment folder. 
     strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\" 

     ' Check each selected item for attachments. 

     For Each objMsg In objSelection 

     Set objAttachments = objMsg.Attachments 
     lngCount = objAttachments.Count 
     If lngCount > 0 Then 

     ' Use a count down loop for removing items 
     ' from a collection. Otherwise, the loop counter gets 
     ' confused and only every other item is removed. 

     For i = lngCount To 1 Step -1 

     ' Get the file name. 
     strFile = objAttachments.item(i).FileName 
     If Right(strFile, 3) = "pdf" Then 

     ' Combine with the path to the Temp folder. 
     withParts = strFile 
     withoutParts = Replace(withParts, ".pdf", "") 

     strFile = strFolderPath & withoutParts & "\" & strFile 

     ' Save the attachment as a file. 
     objAttachments.item(i).SaveAsFile strFile 

    End If 
     Next i 
     End If 


     Next 

    ExitSub: 

    Set objAttachments = Nothing 
    Set objMsg = Nothing 
    Set objSelection = Nothing 
    Set objOL = Nothing 
    End Sub 

自动运行它时，Outlook启动只是把它的对象“ThisOutlookSession”文件夹并将其命名为“子Application_Startup（）”。不要忘记之前启用宏。