Vba 接收电子邮件的自动类别分配+；文件名附件

我制作了一个脚本，根据主题中的一些首字母缩写、正文中的一些单词、发件人等为所有选定的电子邮件分配一个类别

Public Sub autocategories()
    Dim olItem As Object
    For Each olItem In Application.ActiveExplorer.Selection
        If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB1"
        ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB2"
        ElseIf InStr(1, olItem.Sender, "SEN1", vbTextCompare) > 0 Then
            olItem.Categories = "SEN1"
        ElseIf InStr(1, olItem.Sender, "SEN2", vbTextCompare) > 0 Then
            olItem.Categories = "SEN2"
        ElseIf InStr(1, olItem.Body, "BOD1", vbTextCompare) > 0 Then
            olItem.Categories = "BOD1"
        ElseIf InStr(1, olItem.Body, "BOD2", vbTextCompare) > 0 Then
            olItem.Categories = "BOD2"
        End If
        olItem.Save
    Next olItem
    Set olItem = Nothing
End Sub

我制作了第二个脚本，自动为所有发送的电子邮件分配一个类别

Private Sub Application_ItemSend(ByVal olItem As Object, Cancel As Boolean)
    With olItem
        If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB1"
            olItem.Save
        ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB2"
            olItem.Save
        ElseIf InStr(1, olItem.Body, "BOD1", vbTextCompare) > 0 Then
            olItem.Categories = "BOD1"
            olItem.Save
        ElseIf InStr(1, olItem.Body, "BOD2", vbTextCompare) > 0 Then
            olItem.Categories = "BOD2"
            olItem.Save
        Else: End If
    End With
lbl_Exit:
    Exit Sub
End Sub

对于收到的电子邮件：
-我希望任务自动完成，而不必选择电子邮件并单击宏按钮
-使用规则不是一个选项，因为它需要更新密钥注册表，这是我的公司所禁止的

对于接收和发送的电子邮件：
-我想识别附件的文件名
-我试过这个：

ElseIf InStr(1, olItem.Attachemnts, "[NAME1]", vbTextCompare) > 0 Then
    olItem.Categories = "[NAME1]"
    olItem.Save

诸如此类

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private WithEvents colSentItems As Outlook.Items

Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace

  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
  Set colSentItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
Dim objAtt As Outlook.Attachment
If TypeName(Item) = "MailItem" Then
    'MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    'Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")

            If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
                Item.Categories = "SUB1"
            ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
                Item.Categories = "SUB2"
            ElseIf InStr(1, Item.Sender, "SEN1", vbTextCompare) > 0 Then
                Item.Categories = "SEN1"
            ElseIf InStr(1, Item.Sender, "SEN2", vbTextCompare) > 0 Then
                Item.Categories = "SEN2"
            ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
                Item.Categories = "BOD1"
            ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
                Item.Categories = "BOD2"
            End If
            For Each objAtt In Item.Attachments
                'objAtt.SaveAsFile saveFolder & "\" & Item.Parent & "\" & objAtt.DisplayName
                If InStr(1, objAtt.DisplayName, "[NAME1]", vbTextCompare) > 0 Then
                    Item.Categories = "[NAME1]"
                    Item.Save
                End If
                Set objAtt = Nothing
            Next
            Item.Save
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub



Private Sub colSentItems_ItemAdd(ByVal Item As Object)
    If Item.Class = olMail Then
       'Item.ShowCategoriesDialog
        If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
            Item.Categories = "SUB1"
        ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
            Item.Categories = "SUB2"
        ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
            Item.Categories = "BOD1"
        ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
            Item.Categories = "BOD2"
        End If
        Item.Save
    End If
End Sub

附件

For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\" & itm.Parent & "\" & objAtt.DisplayName
Next

诸如此类

Option Explicit
Private WithEvents inboxItems As Outlook.Items
Private WithEvents colSentItems As Outlook.Items

Private Sub Application_Startup()
  Dim outlookApp As Outlook.Application
  Dim objectNS As Outlook.NameSpace

  Set outlookApp = Outlook.Application
  Set objectNS = outlookApp.GetNamespace("MAPI")
  Set inboxItems = objectNS.GetDefaultFolder(olFolderInbox).Items
  Set colSentItems = objectNS.GetDefaultFolder(olFolderSentMail).Items
End Sub

Private Sub inboxItems_ItemAdd(ByVal Item As Object)
On Error GoTo ErrorHandler
Dim Msg As Outlook.MailItem
Dim MessageInfo
Dim Result
Dim objAtt As Outlook.Attachment
If TypeName(Item) = "MailItem" Then
    'MessageInfo = "" & _
        "Sender : " & Item.SenderEmailAddress & vbCrLf & _
        "Sent : " & Item.SentOn & vbCrLf & _
        "Received : " & Item.ReceivedTime & vbCrLf & _
        "Subject : " & Item.Subject & vbCrLf & _
        "Size : " & Item.Size & vbCrLf & _
        "Message Body : " & vbCrLf & Item.Body
    'Result = MsgBox(MessageInfo, vbOKOnly, "New Message Received")

            If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
                Item.Categories = "SUB1"
            ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
                Item.Categories = "SUB2"
            ElseIf InStr(1, Item.Sender, "SEN1", vbTextCompare) > 0 Then
                Item.Categories = "SEN1"
            ElseIf InStr(1, Item.Sender, "SEN2", vbTextCompare) > 0 Then
                Item.Categories = "SEN2"
            ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
                Item.Categories = "BOD1"
            ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
                Item.Categories = "BOD2"
            End If
            For Each objAtt In Item.Attachments
                'objAtt.SaveAsFile saveFolder & "\" & Item.Parent & "\" & objAtt.DisplayName
                If InStr(1, objAtt.DisplayName, "[NAME1]", vbTextCompare) > 0 Then
                    Item.Categories = "[NAME1]"
                    Item.Save
                End If
                Set objAtt = Nothing
            Next
            Item.Save
End If
ExitNewItem:
    Exit Sub
ErrorHandler:
    MsgBox Err.Number & " - " & Err.Description
    Resume ExitNewItem
End Sub



Private Sub colSentItems_ItemAdd(ByVal Item As Object)
    If Item.Class = olMail Then
       'Item.ShowCategoriesDialog
        If InStr(1, Item.Subject, "=SUB1=", vbTextCompare) > 0 Then
            Item.Categories = "SUB1"
        ElseIf InStr(1, Item.Subject, "=SUB2=", vbTextCompare) > 0 Then
            Item.Categories = "SUB2"
        ElseIf InStr(1, Item.Body, "BOD1", vbTextCompare) > 0 Then
            Item.Categories = "BOD1"
        ElseIf InStr(1, Item.Body, "BOD2", vbTextCompare) > 0 Then
            Item.Categories = "BOD2"
        End If
        Item.Save
    End If
End Sub

附件

For Each objAtt In itm.Attachments
    objAtt.SaveAsFile saveFolder & "\" & itm.Parent & "\" & objAtt.DisplayName
Next

试试下面的方法-

Option Explicit
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
        autocategories Item
    End If
End Sub

Public Sub autocategories(ByVal olItem As Object)
        If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB1"
        ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB2"
        ElseIf InStr(1, olItem.Sender, "SEN1", vbTextCompare) > 0 Then
            olItem.Categories = "SEN1"
        ElseIf InStr(1, olItem.Sender, "SEN2", vbTextCompare) > 0 Then
            olItem.Categories = "SEN2"
        ElseIf InStr(1, olItem.body, "BOD1", vbTextCompare) > 0 Then
            olItem.Categories = "BOD1"
        ElseIf InStr(1, olItem.body, "BOD2", vbTextCompare) > 0 Then
            olItem.Categories = "BOD2"
        End If
        olItem.Save
    Set olItem = Nothing
End Sub


Private Sub TestMsg()
    Dim olMsg As Outlook.MailItem
    Set olMsg = ActiveExplorer.selection.Item(1)
    FwdItem olMsg
End Sub

试试下面的方法-

Option Explicit
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
        autocategories Item
    End If
End Sub

Public Sub autocategories(ByVal olItem As Object)
        If InStr(1, olItem.Subject, "=SUB1=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB1"
        ElseIf InStr(1, olItem.Subject, "=SUB2=", vbTextCompare) > 0 Then
            olItem.Categories = "SUB2"
        ElseIf InStr(1, olItem.Sender, "SEN1", vbTextCompare) > 0 Then
            olItem.Categories = "SEN1"
        ElseIf InStr(1, olItem.Sender, "SEN2", vbTextCompare) > 0 Then
            olItem.Categories = "SEN2"
        ElseIf InStr(1, olItem.body, "BOD1", vbTextCompare) > 0 Then
            olItem.Categories = "BOD1"
        ElseIf InStr(1, olItem.body, "BOD2", vbTextCompare) > 0 Then
            olItem.Categories = "BOD2"
        End If
        olItem.Save
    Set olItem = Nothing
End Sub


Private Sub TestMsg()
    Dim olMsg As Outlook.MailItem
    Set olMsg = ActiveExplorer.selection.Item(1)
    FwdItem olMsg
End Sub

---

不需要outlookApp，Outlook中已经有代码-只需使用应用程序“使用应用程序”是什么意思？嘿，抱歉，代码不起作用。我复制粘贴在“ThisOutlookSession”中，并用我需要的内容进行更新，但没有结果。你能告诉我，在我的初始脚本中，如何添加一行以便它能够识别附件中的文件名吗？那会有帮助的！Thanksitem.Attachments（0）.DisplayName是否像这样

ElesIf InStr（1，olItem.Attachments（0）.DisplayName，“example”，vbTextCompare）>0然后olItem.Categories=“CAT1”

不需要Outlook应用程序，代码已经在Outlook中-只需使用应用程序“使用应用程序”是什么意思？嘿，抱歉，代码不起作用。我复制粘贴在“ThisOutlookSession”中，并用我需要的内容进行更新，但没有结果。你能告诉我，在我的初始脚本中，如何添加一行以便它能够识别附件中的文件名吗？那会有帮助的！Thanksitem.Attachments（0）.DisplayName是否像这样

ElesIf InStr（1，olItem.Attachments（0）.DisplayName，“example”，vbTextCompare）>0，然后是olItem.Categories=“CAT1”

嘿，谢谢你的评论。实际上，我希望我的第一个脚本能够识别名称附件，并根据它分配一个类别。我应该如何包括它？因此，在我编写的第一个代码中包含这样的内容：ElseIf InStr（1，Atmt.FileName，“example”，vbTextCompare）>0，然后是olItem.Categories=“CAT1”，保留相同的宏按钮对我来说非常重要，这样我就可以根据主题、正文、发件人和文件名附件对电子邮件进行排序。自动化并不是那么重要，谢谢你的评论。实际上，我希望我的第一个脚本能够识别名称附件，并根据它分配一个类别。我应该如何包括它？因此，在我编写的第一个代码中包含这样的内容：ElseIf InStr（1，Atmt.FileName，“example”，vbTextCompare）>0，然后是olItem.Categories=“CAT1”，保留相同的宏按钮对我来说非常重要，这样我就可以根据主题、正文、发件人和文件名附件对电子邮件进行排序。自动化并不是那么重要