使用VBA从Dynamic-Array分配Outlook 2010类别

Question

我试图从txt文件构建发件人域阵列，以便在特定邮箱收件箱中将邮件分类指定给电子邮件。 txt文件将作为示例，但每个P1，P2 ...文件每个文件将有近500个域。

@Symantec.com 
@Microsoft.com 
@McAfee.com 
@TigerDirect.com 

到目前为止，我设法解决所有的错误（下标越界，类型不匹配...等），我用它获取和它运行没有错误。尽管如此，该脚本没有分配类别，并且由于Outlook 2010 VBA编辑器的有限视图，我无法检查变量内部的内容。在它为1邮箱工作后，我将为Outlook左窗格（约24）上的每个邮箱制作多个邮箱＃_ItemAdd Subs，因此调用函数。

我在“ThisOutlookSession”（从VBA编辑器直接复制减去安全性的通用邮箱名称）中拥有这整个事物。

'Our inboxes are named here 
'Variables for Display Name of the Mailbox goes here 
Private WithEvents Mailbox1 As Outlook.Items 
Option Explicit 
Dim P1() As String 
Dim P2() As String 
Dim P3() As String 
Dim P4() As String 
Dim P5() As String 

Function GetP1() 
    Dim i As Integer 
    i = 0 
    Open "C:\Priority\P1.txt" For Input As #1 
    Do While Not EOF(1) ' Loop until end of file. 
    ReDim Preserve P1(i) ' Redim the array for the new element 
    Line Input #1, P1(i) ' read next line from file and add text to the array 
     i = i + 1 
     Loop 
    Close #1 
End Function 

Function GetP2() 
    Dim i As Integer 
    i = 0 
    Open "C:\Priority\P2.txt" For Input As #1 ' Open file for input. 
    Do While Not EOF(1) ' Loop until end of file. 
    ReDim Preserve P2(i) ' Redim the array for the new element 
    Line Input #1, P2(i) ' read next line from file and add text to the array 
     i = i + 1 
     Loop 
    Close #1 
End Function 

Function GetP3() 
    Dim i As Integer 
    i = 0 
    Open "C:\Priority\P3.txt" For Input As #1 ' Open file for input. 
    Do While Not EOF(1) ' Loop until end of file. 
    ReDim Preserve P3(i) ' Redim the array for the new element 
    Line Input #1, P3(i) ' read next line from file and add text to the array 
     i = i + 1 
     Loop 
    Close #1 
End Function 

Function GetP4() 
    Dim i As Integer 
    i = 0 
    Open "C:\Priority\P4.txt" For Input As #1 ' Open file for input. 
    Do While Not EOF(1) ' Loop until end of file. 
    ReDim Preserve P4(i) ' Redim the array for the new element 
    Line Input #1, P4(i) ' read next line from file and add text to the array 
     i = i + 1 
     Loop 
    Close #1 
End Function 

Function GetP5() 
    Dim i As Integer 
    i = 0 
    Open "C:\Priority\P5.txt" For Input As #1 ' Open file for input. 
    Do While Not EOF(1) ' Loop until end of file. 
    ReDim Preserve P5(i) ' Redim the array for the new element 
    Line Input #1, P5(i) ' read next line from file and add text to the array 
     i = i + 1 
     Loop 
    Close #1 
End Function 


Function Categorize(strheader, Item) 
    'categorizes mail items P1 if a Priority 1 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P1) To UBound(P1) 
    If LCase(strheader.Contains(P1)) Then 
     With Msg 
     Item.Categories = Item.Categories & "," & "0 Pri 1" 
     Item.Save 
     End With 
     Exit For 
    End If 
    Next i 

    'categorizes mail items P2 if a Priority 2 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P2) To UBound(P2) 
    If LCase(strheader.Contains(P2)) Then 
     With Msg 
     Item.Categories = Item.Categories & "," & "0 Pri 2" 
     Item.Save 
     End With 
     Exit For 
    End If 
    Next i 

    'categorizes mail items P3 if a Priority 3 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P3) To UBound(P3) 
    If LCase(strheader.Contains(P3)) Then 
     With Msg 
     Item.Categories = Item.Categories & "," & "0 Pri 3" 
     Item.Save 
     End With 
     Exit For 
    End If 
    Next i 

    'categorizes mail items P4 if a Priority 4 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P4) To UBound(P4) 
    If LCase(strheader.Contains(P4)) Then 
     With Msg 
     Item.Categories = Item.Categories & "," & "0 Pri 4" 
     Item.Save 
     End With 
     Exit For 
    End If 
    Next i 

    'categorizes mail items P5 if a Priority 5 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P5) To UBound(P5) 
    If LCase(strheader.Contains(P5)) Then 
     With Msg 
     Item.Categories = Item.Categories & "," & "0 Pri 5" 
     Item.Save 
     End With 
     Exit For 
    End If 
    Next i 

End Function 



'Set our inboxes to actual folder paths on startup. Works on any mailbox visible on the left pane in Outlook. 
'Display Name of the Mailbox goes here with Variable 
Private Sub Application_Startup() 

    Dim objNS As Outlook.NameSpace 
    Set objNS = GetNamespace("MAPI") 


    Set Mailbox1 = objNS.Folders("Mailbox1 Display name").Folders("Inbox").Items 
    Call GetP1 
    Call GetP2 
    Call GetP3 
    Call GetP4 
    Call GetP5 


End Sub 


'Grab the Internet headers of a mailitem as a string 
Function GetInetHeaders(olkMsg As Outlook.MailItem) As String 
    ' Purpose: Returns the internet headers of a message.' 
    ' Written: 4/28/2009' 
    ' Author: BlueDevilFan' 
    ' http://techniclee.wordpress.com/ 
    ' Outlook: 2007' 
    Const PR_TRANSPORT_MESSAGE_HEADERS = "http://schemas.microsoft.com/mapi/proptag/0x007D001E" 
    Dim olkPA As Outlook.PropertyAccessor 
    Set olkPA = olkMsg.PropertyAccessor 
    GetInetHeaders = olkPA.GetProperty(PR_TRANSPORT_MESSAGE_HEADERS) 
    Set olkPA = Nothing 
End Function 

' use the name delared in Private WithEvents 
Private Sub smbea1_ItemAdd(ByVal Item As Object) 

If Item.Class = olMail Then 
    Dim objNS As Outlook.NameSpace 
    Dim Msg As Outlook.MailItem 
    Dim strheader As String 


    Set Msg = Item 
    Set objNS = Outlook.GetNamespace("MAPI") 
    'VERY IMPORTANT 

    strheader = GetInetHeaders(Msg) 

    Call Categorize(strheader) 


ExitProc: 
    'Clear Variables 
    Set Msg = Nothing 
    Set objNS = Nothing 
    Set olkAtt = Nothing 

End If 
End Sub 

Answer 1

你混合味精项目，没有包含，...

Function Categorize(strheader, Item) 
    Dim i As Long 
    'categorizes mail items P1 if a Priority 1 domain is found in the internet header 
    'retains any existing categories (Create one for each Categories) 
    For i = LBound(P1) To UBound(P1) 

     'If LCase(strheader.Contains(P1)) Then 
     If InStr(LCase(strheader), LCase(P1(i))) Then 
      'With Msg 
       'Item.Categories = Item.Categories & "," & "0 Pri 1" 
       'Item.Save 
      'End With 
      With Item 
       .Categories = .Categories & "," & "0 Pri 1" 
       .Save 
      End With 
      Exit For 
     End If 
    Next i 
End Function 


' use the name delared in Private WithEvents 
'Private Sub smbea1_ItemAdd(ByVal Item As Object) 
Private Sub Mailbox1_ItemAdd(ByVal Item As Object) 

    Dim objNS As Outlook.Namespace 

    'Dim Msg As Outlook.mailItem 

    Dim strheader As String 

    If Item.Class = olMail Then 

     'Set Msg = Item 
     Set objNS = Outlook.GetNamespace("MAPI") 

     'strheader = GetInetHeaders(Msg) 
     strheader = GetInetHeaders(Item) 

     'Call Categorize(strheader) 
     Call Categorize(strheader, Item) 

    End If 

ExitProc: 
    'Clear Variables 
    Set Msg = Nothing 
    Set objNS = Nothing 
    'Set olkAtt = Nothing 

End Sub