【发布时间】：2016-01-27 05:26:11
【问题描述】：
我正在尝试从 txt 文件构建发件人域数组，以便在特定邮箱的收件箱中为电子邮件分配类别。 txt 文件将作为示例，但每个 P1、P2... 文件每个文件将有接近 500 个域。
@Symantec.com
@Microsoft.com
@McAfee.com
@TigerDirect.com
到目前为止，我设法修复了我遇到的所有错误（下标超出范围、类型不匹配...等），并且它运行时没有错误。尽管如此，该脚本并未分配类别，并且由于 Outlook 2010 VBA 编辑器的有限视图，我无法检查变量内部的内容。在它适用于 1 个邮箱后，我将为 Outlook 左窗格（大约 24 个）上的每个邮箱创建多个 Mailbox#_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
【问题讨论】：
标签： vba function outlook categories dynamic-arrays