基于服务器的规则，将 500+ 个地址整理到 ~150 个收件箱文件夹中

Question

我有一个公司项目，其中~500个客户向我的项目收件箱发送电子邮件。这些客户对应于~150个办公室(我有一个电子邮件地址的Excel列表和相应的办公室(。

每个办公室都应该有一个Outlook文件夹，所以我可以快速检查过去与特定办公室的通信。

项目收件箱由几个同事照顾和使用，因此是基于服务器而不是基于客户端的规则。

如何设置？我以伪代码形式出现的简单想法：

for each arriving email
    if (from-adress is in "email & office-List")
        move that email to outlook folder "according office name"
    end if
end for

外发电子邮件也是如此：

for each sent email
    if (to-adress is in "email & office-List")
        move that email to outlook folder "according office name"
    end if
end for

感谢您的建议！

。此外，是否可以从名称列表以编程方式创建Outlook文件夹？

Answer 1

我的解决方案是我每天手动运行的 skript，因为我的雇主不允许在到达的消息上使用脚本。

简而言之，逻辑是：

fetch list of emails & their corresponding offices (both string lists)
set up folder variables
loop through messages, and move them eventually

代码看起来像

Option Compare Text ' makes string comparisons case insensitive
Sub sortEmails()
'sorts the emails into folders
Dim msg As Outlook.MailItem
Dim itm As Object
Dim adress As String
Dim pa As Outlook.PropertyAccessor
Const PR_SMTP_ADDRESS As String = _
        "http://schemas.microsoft.com/mapi/proptag/0x39FE001E"
'1) fetch emails
GetEMailsFolders locIDs, emails, n
'1.5) fetch folder objects
'Create an instance of Outlook & inbox reference
Dim Inbox As Outlook.MAPIFolder
Dim outbox As Outlook.MAPIFolder

Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("[e-mail]")
    objOwner.Resolve
'Set inbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
Set Inbox = NS.Folders("[e-mail]").Folders("Inbox")
Set outbox = NS.Folders("[e-mail]").Folders("Sent Items")
Dim basefolder As Outlook.MAPIFolder
Dim bfName As String
bfName = "Offices" 'name of the folder for the offices
Set basefolder = MkDirConditional(Inbox.Folders("Project folder"), bfName)

'2)loop through inbox & outbox emails
Dim destination As Outlook.MAPIFolder
Dim fold(1 To 2) As Outlook.MAPIFolder
Set fold(1) = Inbox
Set fold(2) = outbox
Dim LocID As String
For Each fol In fold 'loop through inbox & outbox
    Debug.Print fol
    'reverse fo loop because otherwise moved messages modify indices of following messages
    For i = fol.Items.Count To 1 Step -1 'Each itm In fol.Items
        Set itm = fol.Items(i)
        If TypeName(itm) = "MailItem" Then ' others are AppointmentItem, MeetingItem, or TaskItem
            Set msg = itm
            'Debug.Print " " & msg.Subject
            If fol = Inbox Then
                ' there are two formats of email adrersses.
                If msg.SenderEmailType = "EX" Then 'check two kinds of email adress formats
                    adress = msg.Sender.GetExchangeUser().PrimarySmtpAddress
                ElseIf msg.SenderEmailType = "SMTP" Then 'SMTP case
                    adress = msg.SenderEmailAddress
                Else
                    Debug.Print "  neither EX nor SMTP" & msg.Subject;
                End If
                pos = Findstring(adress, emails) ' position in the email / standort list
            ElseIf fol = outbox Then
                For Each rec In msg.Recipients
                    Set pa = rec.PropertyAccessor
                    adress = pa.GetProperty(PR_SMTP_ADDRESS)
                    pos = Findstring(adress, emails)
                    If pos > 0 Then
                        Exit For
                    End If
                Next rec
            End If
            '4.5) if folder doesnt exist, create it
            '5) move message
            If pos > 0 Then
               'Debug.Print "  Its a Match!!"
               LocID = locIDs(pos)
               Set destination = MkDirConditional(basefolder, LocID)
               Debug.Print "  " & Left(msg.Subject, 20), adress, pos, destination
               msg.Move destination
            Else
               'Debug.Print "  not found!"
            End If
        Else
            'Debug.Print "  " & "non-mailitem", itm.Subject
        End If
    Next i
Next fol
End Sub
'//  Function - Check folder Exist
Private Function FolderExists(Inbox As Outlook.MAPIFolder, FolderName As String) As Boolean
    Dim Sub_Folder As MAPIFolder
    On Error GoTo Exit_Err
    Set Sub_Folder = Inbox.Folders(FolderName)
    FolderExists = True
        Exit Function
Exit_Err:
    FolderExists = False
End Function
Function MkDirConditional(basefolder As Outlook.MAPIFolder, newfolder As String) As Outlook.MAPIFolder
Debug.Print newfolder & " ";
If FolderExists(basefolder, newfolder) Then
    'folder exists, so just skip
    Set MkDirConditional = basefolder.Folders(newfolder)
    Debug.Print "exists already"
Else
    'folder doesnt exist, make it
    Set MkDirConditional = basefolder.Folders.Add(newfolder)
    Debug.Print "created"
End If
End Function
'function to compare two strings, min the option compare text at the top line
Function Findstring(str As String, arr As Variant) As Integer
'returns -1 if a string is not found, otherwise its index
Findstring = -1
Dim i As Integer
i = 1
For Each Item In arr
    'Debug.Print Item
    If str = Item Then
        Findstring = i
        Exit For
    End If
    i = i + 1
Next
End Function
' function to fetch the lists of emails and offices
Sub GetEMailsFolders(ByRef rng1 As Variant, ByRef rng2 As Variant, ByRef n As Variant)
'declare variables
Dim xExcelFile As String
Dim xExcelApp As Excel.Application
Dim xWb As Excel.Workbook
Dim xWs As Excel.Worksheet
Dim xExcelRange As Excel.Range
Dim TotalRows As Long
'declare SPOC xls file
xExcelFile = "adresses.xlsx"
'open the file
Set xExcelApp = CreateObject("Excel.Application")
Set xWb = xExcelApp.Workbooks.Open(xExcelFile)
Set xWs = xWb.Sheets(1)
'extract LocIDs (column A), emails (column O) and thir number
n = xWs.Range(xWs.Range("A2"), xWs.Range("A2").End(xlDown)).Count ' works
ReDim rng1(1 To n) As Variant
ReDim rng2(1 To n) As Variant
For i = 1 To n
    rng1(i) = xWs.Cells(i + 1, 1)
    rng2(i) = xWs.Cells(i + 1, 15)
    'Debug.Print rng1(i), rng2(i)
Next
Debug.Print "done reading LocIDs & emails"
End Sub