使用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