Question

我试图了解如何编写收件箱以维护包含域名列出的子文件夹的收件箱，例如：

Inbox->@client1.com->client1 e-mails

我在这里蠢蠢欲动，这与我想要得到的内容很接近：
Move e-mails by senderemailaddress outlook macro

Option Explicit
Public Sub Move_Items()
   '// Declare your Variables
    Dim Inbox As Outlook.MAPIFolder
    Dim SubFolder As Outlook.MAPIFolder
    Dim Folder As Outlook.MAPIFolder '<- has been added
    Dim olNs As Outlook.NameSpace
    Dim Item As Outlook.MailItem
    Dim Items As Outlook.Items
    Dim lngCount As Long

'    On Error GoTo MsgErr
   '// Set Inbox Reference
    Set olNs = Application.GetNamespace("MAPI")
    Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
    Set Folder = Application.Session.PickFolder
    Set Items = Inbox.Items

   '// Loop through the Items in the folder backwards
    For lngCount = Inbox.Items.Count To 1 Step -1
        Set Item = Inbox.Items.Item(lngCount)

        Debug.Print Item.Subject

        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress

'               // Email_One
                Case "bb@gmail.com"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Temp")
                    Set Item = Items.Find("[SenderEmailAddress] = 'bb@gmail.com'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

'               // Email_Two
                Case "aa@gmail.com"
'                   // Set SubFolder of Inbox
                    Set SubFolder = Inbox.Folders("Temp")
                    Set Item = Items.Find("[SenderEmailAddress] = 'aa@gmail.com'")
                    If TypeName(Item) <> "Nothing" Then
'                       // Mark As Read
                        Item.UnRead = False
'                       // Move Mail Item to sub Folder
                        Item.Move SubFolder
                    End If

            End Select
        End If
    Next lngCount

MsgErr_Exit:
    Set Inbox = Nothing
    Set SubFolder = Nothing
    Set olNs = Nothing
    Set Item = Nothing
    Set Items = Nothing

    Exit Sub

'// Error information
MsgErr:
    MsgBox "An unexpected Error has occurred." _
         & vbCrLf & "Error Number: " & Err.Number _
         & vbCrLf & "Error Description: " & Err.Description _
         , vbCritical, "Error!"
    Resume MsgErr_Exit
End Sub

缺少的是自动化部分，但是，我正在寻找＆＃34;运行和文件＆＃34;检查子文件夹是否存在的方法。（例如@ client1.com）

如果子文件夹确实存在且域匹配，请在那里移动电子邮件。如果没有，请为具有新域的客户端创建新的子文件夹，并将其存入其中。

有人可以帮忙吗？

Answer 1

只需使用 Right - Len - Instr 和 Split 功能

实施例

Dim FolderName As String
FolderName = Right("bb@gmail.com", _
               Len("bb@gmail.com") _
           - InStr("bb@gmail.com", "@"))

Debug.Print FolderName 'Immediate Window prints gmail.com

FolderName = "@" & FolderName

Debug.Print FolderName 'Immediate Window prints @gmail.com

一旦你有 FolderName ，然后检查文件夹是否存在或者创建一个

If FolderExists(Inbox, FolderName) = True Then
    Set SubFolder = Inbox.Folders(FolderName)
Else
    Set SubFolder = Inbox.Folders.Add(FolderName)
End If

'//  Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, FolderName As String)
    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

您的代码应该是

        If Item.Class = olMail Then
            Select Case Item.SenderEmailAddress

'               // Email_One
                Case "bb@gmail.com"

'                   // Set SubFolder of Inbox
                Dim FolderName As String
                FolderName = Right("bb@gmail.com", _
                               Len("bb@gmail.com") _
                           - InStr("bb@gmail.com", "@"))

                Debug.Print FolderName 'Immediate Window prints gmail.com

                FolderName = "@" & FolderName

                Debug.Print FolderName 'Immediate Window prints @gmail.com

                '// Check if folder exist else create one
                If FolderExists(Inbox, FolderName) = True Then
                    Set SubFolder = Inbox.Folders(FolderName)
                Else
                    Set SubFolder = Inbox.Folders.Add(FolderName)
                End If

在 Private Function FolderExists

之后添加 End Sub

按域组织电子邮件;进入@ sender.com文件夹

1 个答案: