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

Question

我使用以下代码将电子邮件附件保存到文件夹中。我想在每次打开outlook时自动运行此vba并检查我的creditchecks@hewden.co.uk收件箱中的所有电子邮件（非默认收件箱）。

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

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("credutchecks@hewden.co.uk")之类的内容用于收件箱文件夹同一级别的文件夹。以下是您修改的代码：

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("credutchecks@hewden.co.uk")

        'This is for a folder inside the inbox folder
        'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("credutchecks@hewden.co.uk")

    ' 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启动时自动运行它，只需将其放在objects文件夹中的“ThisOutlookSession”上，并将其命名为“Sub Application_Startup（）”。不要忘记以前启用宏。