Question

我正在处理一个代码，通过使用主题过滤器将附件下载到上下文中的文件夹位置。

在互联网上进行了长时间的搜索后，我的代码正在运行，但问题是我想将关键字放在主题过滤器中，以便在主题每天都在不断变化时下载附件

e.g。一天Sub: training_24357，第二天training_24359。

另外，我希望每隔5分钟自动运行一次代码，任何帮助都会非常感激，

下面是我的代码。

Sub Attachment()

    Dim OutOpened As Boolean
    Dim App As Outlook.Application
    Dim Ns As Outlook.NameSpace
    Dim Folder As Outlook.MAPIFolder
    Dim Attach As Outlook.Attachment
    Dim Item As Object
    Dim MailItem As Outlook.MailItem
    Dim subject As String
    Dim saveFolder As String
    Dim dateFormat As String

    saveFolder = "D:\Outlook\POS Visit Report"
    If Right(saveFolder, 1) <> "\" Then saveFolder = saveFolder & "\"

        subject = """*POS Visit*"""

        OutOpened = False
        On Error Resume Next
        Set App = GetObject(, "Outlook.Application")
        If Err.Number <> 0 Then
            Set App = New Outlook.Application
            OutOpened = True
        End If
   On Error GoTo 0
        If App Is Nothing Then
            MsgBox "Cannot Start Outlook Mail", vbExclamation
            Exit Sub
        End If
    Set Ns = App.GetNamespace("MAPI")
    Set Folder = Ns.GetDefaultFolder(olFolderInbox)

        If Not olFolder Is Nothing Then
            For Each Item In olFolder.Items
                If Item.Class = Outlook.ObjectClass.olMail Then
                    Set MailItem = Item
                    If MailItem.subject = subject Then
                        Debug.Print MailItem.subject
                        For Each Attach In MailItem.Attachments
                        dateFormat = Format(Now(), "yyyy-mm-dd H-mm")
                        Attach.SaveAsFile saveFolder & "(" & dateFormat & ")" & " " & Attach
                        Next
                    End If
                End If
            Next
        End If


    If OutOpened Then App.Quit
    Set App = Nothing

End Sub

Answer 1

要搜索带附件的项目和按主题行，您可以使用Items.Restrict Method过滤包含过滤器所有匹配项目的项目集合

过滤示例： [Attachment & Subject Like '%training%']

Filter = "@SQL=" & Chr(34) & "urn:schemas:httpmail:subject" & _
                   Chr(34) & " Like '%training%' AND " & _
                   Chr(34) & "urn:schemas:httpmail:hasattachment" & _
                   Chr(34) & "=1"

VBA示例 https://stackoverflow.com/a/42547062/4539709或https://stackoverflow.com/a/42777485/4539709

现在，如果您从Outlook运行代码，则无需GetObject或Set App = New Outlook.Application只需Set Ns = Application.GetNamespace("MAPI")

在将项目添加到收件箱时运行代码 - 尝试使用Application.Startup Event (Outlook)和 Items_ItemAdd Event (Outlook)

_{Items.ItemAdd事件将一个或多个Items添加到指定集合时发生。当大量项目一次添加到文件夹时，此事件不会运行。}

代码示例：

Private WithEvents Items As Outlook.Items
Private Sub Application_Startup()
    Dim olNs As Outlook.NameSpace
    Dim Inbox  As Outlook.MAPIFolder

    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Items = Inbox.Items
End Sub

Private Sub Items_ItemAdd(ByVal Item As Object)    
    If TypeOf Item Is Outlook.MailItem Then
        '// call sub here
    End If
End Sub

如何使用过滤器在主题中搜索带附件和关键字的项目

1 个答案: