Question

我想将邮件从发件人移动到我为发件人创建的文件夹。

SenderName显示为＆＃34; Doe，John（US）＆＃34;我的文件夹将是＆＃34; Doe，John＆＃34;。

我需要做什么才能将SenderName与下面两级以下的子文件夹名称进行比较 "Inbox". I.e. Inbox→Folder1→"Doe, John".

Public Sub MoveToFolder()
Dim objOutlook As Outlook.Application
Dim objNameSpace As Outlook.NameSpace
Dim objDestFolder As Outlook.MAPIFolder
Dim objSourceFolder As Outlook.Folder
Dim currentExplorer As Explorer
Dim Selection As Selection
Dim obj As Object

Dim objSubfolder As Outlook.Folder
Dim olsubFolder As Outlook.Folder

Dim olApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim Msg As Outlook.MailItem

Dim objVariant As Variant
Dim lngMovedItems As Long
Dim intCount As Integer

Set objOutlook = Application
Set objNameSpace = objOutlook.GetNamespace("MAPI")
Set currentExplorer = objOutlook.ActiveExplorer
Set Selection = currentExplorer.Selection
Set objSourceFolder = currentExplorer.CurrentFolder
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")

Set olFolder = objNS.GetDefaultFolder(olFolderInbox)
Set olFolder = olFolder.Folders("Inbox")
Set colFolders = objParentFolder.Folders

For Each obj In Selection
    Set objVariant = obj

    Dim sfName As Object
    Set sfName = Left(objVariant.senderName, Len(objVariant.senderName) - 5)

    If objVariant.Class = olMail Then

        On Error Resume Next
        ' Use These lines if the destination folder
        '  is not a subfolder of the current folder
        For Each objSubfolder In colFolders
            For Each olsubFolder In objSubfolder
                If olsubFolder.Name = sfName Then
                    Set objDestFolder = objSubfolder
                    MsgBox "Ductus Exemplo"
                    'objVariant.Move objDestFolder
                    'count the # of items moved
                    lngMovedItems = lngMovedItems + 1
                     'Display the number of items that were moved.
                    MsgBox "Moved " & lngMovedItems & " messages(s) from  " & _
                    sfName & "to " & objDestFolder
                Else
                    If objDestFolder Is Nothing Then
                        MsgBox "No Folder Found for " & sfName
                        'Set objDestFolder = objSourceFolder.Folders.Add(sfName)
                        Exit Sub
                    End If

            Next
        Next
    Next
End If
End Sub

Answer 1

目标似乎是在调用时根据SenderName组织选定的邮件项目。

进一步放置，因为当选择中的任何内容移动时（即仅选定的会议项目），您可以在所选文件夹中移动项目。

选择处理项目的文件夹时，该文件夹不能是主子文件夹或其子文件夹。

Option Explicit

Private Const SUB_FDR As String = "Folder1" ' The name of main sub-folder under Inbox to move mails to

Sub MoveSenderToFolder()
    Dim oNS As NameSpace, oMainFDR As Folder, oSubFDR As Folder
    Dim oItem As Variant, iMoved As Long
    On Error Resume Next
    Set oNS = Application.GetNamespace("MAPI")
    On Error GoTo 0
    If oNS Is Nothing Then
        MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()"
    Else
        ' Proceed to Set Folders
        Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox)
        ' Get the sub folder "SUB_FDR" under Inbox
        If Not oMainFDR Is Nothing Then Set oSubFDR = GetSubFolder(oMainFDR, SUB_FDR)
        If oSubFDR Is Nothing Then
            MsgBox "Cannot get the main sub folder """ & SUB_FDR & """ under """ & oMainFDR.Name & """"
        Else
            iMoved = 0
            ' [1] Process the Selected items
            For Each oItem In ActiveExplorer.Selection
                MoveItemToFolder oItem, oSubFDR, iMoved
            Next
            ' [2] Ask to process a Folder if no MailItems are moved from Selection
            If iMoved = 0 Then
                If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then
                    Set oMainFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder
                    ' Only proceed if it's a folder not within Main Sub folder.
                    If Len(Replace(oMainFDR.FolderPath, oSubFDR.FolderPath, "")) = Len(oMainFDR.FolderPath) Then
                        For Each oItem In oMainFDR.Items
                            MoveItemToFolder oItem, oSubFDR, iMoved
                        Next
                    Else
                        MsgBox "Will not process folder/subfolders of the main folder """ & SUB_FDR & """", vbInformation + vbOKOnly, "MoveSenderToFolder()"
                    End If
                End If
            End If
            Set oSubFDR = Nothing
            Set oMainFDR = Nothing
        End If
        Set oNS = Nothing
        MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()"
    End If
End Sub

' Move input item to a sub folder and increment counter
Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oSubFDR As Folder, ByRef iMoved As Long)
    Dim oMail As MailItem, sName As String, oTargetFDR As Folder
    If TypeName(oItem) = "MailItem" Then
        Set oMail = oItem
        sName = GetSenderName(oMail)
        Set oTargetFDR = GetSubFolder(oSubFDR, sName)
        If oTargetFDR Is Nothing Then
            MsgBox "Cannot get Target folder """ & oSubFDR.FolderPath & "\" & sName & """"
        Else
            oMail.Move oTargetFDR
            iMoved = iMoved + 1
        End If
        Set oMail = Nothing
    End If
End Sub

' Extract the Sender Name before any brackets
Private Function GetSenderName(ByRef oItem As MailItem) As String
    Dim sName As String
    sName = oItem.SenderName
    If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0)
    If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0)
    If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0)
    If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0)
    GetSenderName = Trim(sName)
End Function

' Given a name, get the sub-folder object from a main folder (create if required)
Private Function GetSubFolder(ByRef oParentFDR As Folder, ByVal sName As String) As Folder
    On Error Resume Next
    Dim oFDR As Folder
    Set oFDR = oParentFDR.Folders(sName)
    If oFDR Is Nothing Then Set oFDR = oParentFDR.Folders.Add(sName)
    Set GetSubFolder = oFDR
End Function

<小时/> 基于OP评论的代码更新

在Inbox中搜索发件人姓名的所有子文件夹。如果未找到，则提示从“文件夹选择器”创建。

Option Explicit

Private oNS As NameSpace

Sub MoveSenderToFolder()
    Dim oMainFDR As Folder, oSubFDR As Folder
    Dim oItem As Variant, iMoved As Long
    On Error Resume Next
    Set oNS = Application.GetNamespace("MAPI")
    On Error GoTo 0
    If oNS Is Nothing Then
        MsgBox "Cannot get MAPI namespace from Outlook! Abortting!", vbCritical + vbOKOnly, "MoveSenderToFolder()"
    Else
        ' Proceed to Set Folders
        Set oMainFDR = oNS.GetDefaultFolder(olFolderInbox)
        If Not oMainFDR Is Nothing Then
            iMoved = 0
            ' [1] Process the Selected items
            For Each oItem In ActiveExplorer.Selection
                MoveItemToFolder oItem, oMainFDR, iMoved
            Next
            ' [2] Ask to process a Folder if no MailItems are moved from Selection
            If iMoved = 0 Then
                If vbYes = MsgBox("Would you like to select a folder to move mail items?", vbQuestion + vbYesNo, "MoveSenderToFolder()") Then
                    Set oSubFDR = oNS.PickFolder ' Reuse oMainFDR object to the selected folder
                    For Each oItem In oSubFDR.Items
                        MoveItemToFolder oItem, oMainFDR, iMoved
                    Next
                    Set oSubFDR = Nothing
                End If
            End If
            Set oSubFDR = Nothing
            Set oMainFDR = Nothing
        End If
        Set oNS = Nothing
        MsgBox iMoved & " item(s) are moved.", vbInformation + vbOKOnly, "MoveSenderToFolder()"
    End If
End Sub

' Get Folder object based on a Name and a root folder
Private Function GetSenderFolder(ByRef oRootFDR As Folder, ByVal sName As String) As Folder
    Dim oFDR As Folder, oFDR2 As Folder
    For Each oFDR In oRootFDR.Folders
        If oFDR.Name = sName Then
            Set oFDR2 = oFDR
            Exit For
        End If
    Next
    If oFDR Is Nothing Then
        For Each oFDR In oRootFDR.Folders
            Set oFDR2 = GetSenderFolder(oFDR, sName)
            If Not oFDR2 Is Nothing Then Exit For
        Next
    End If
    Set GetSenderFolder = oFDR2
End Function

' Move input item (Mail Items only) to a sub folder and increment counter
Private Sub MoveItemToFolder(ByRef oItem As Variant, ByRef oRootFDR As Folder, ByRef iMoved As Long)
    Dim oMail As MailItem, sName As String, oTargetFDR As Folder
    If TypeName(oItem) = "MailItem" Then
        Set oMail = oItem
        sName = GetSenderName(oMail)
        Set oTargetFDR = GetSenderFolder(oRootFDR, sName)
        If oTargetFDR Is Nothing Then
            If vbYes = MsgBox("Cannot get Target folder """ & oRootFDR.FolderPath & "\" & sName & """" & vbLf & _
                "Would you like to create the folder from folder of your choice?", vbQuestion + vbYesNo) Then
                Set oTargetFDR = CreateSubFolder(sName)
            End If
        End If
        If Not oTargetFDR Is Nothing Then
            oMail.Move oTargetFDR
            iMoved = iMoved + 1
        End If
        Set oMail = Nothing
    End If
End Sub

' Extract the Sender Name before any brackets
Private Function GetSenderName(ByRef oItem As MailItem) As String
    Dim sName As String
    sName = oItem.SenderName
    If InStr(1, sName, "(", vbTextCompare) > 1 Then sName = Split(sName, "(")(0)
    If InStr(1, sName, "<", vbTextCompare) > 1 Then sName = Split(sName, "<")(0)
    If InStr(1, sName, "[", vbTextCompare) > 1 Then sName = Split(sName, "[")(0)
    If InStr(1, sName, "{", vbTextCompare) > 1 Then sName = Split(sName, "{")(0)
    GetSenderName = Trim(sName)
End Function

' Given a name, Create the sub-folder object from Folder Picker
Private Function CreateSubFolder(ByVal sName As String) As Folder
    On Error Resume Next
    Dim oFDR As Folder
    Set oFDR = oNS.PickFolder
    If Not oFDR Is Nothing Then Set oFDR = oFDR.Folders.Add(sName)
    Set CreateSubFolder = oFDR
End Function

Answer 2

假设

发件人子文件夹将位于收件箱下方两级，但不在单个父文件夹下（即“Doe，John”可能会出现在Folder1下，而“Doe，Jane”会出现在Folder2下）
将在执行之前选择宏应处理的所有电子邮件
代码不应为缺少的发件人创建子文件夹 - 因为有多个可能的“父”文件夹 - 但应输出包含缺少的发件人文件夹列表的邮件

触发发件人姓名结束的条件：

空格后面或前面的连字符（即“Doe，John - US”=“Doe，John”和“Huntington-Whiteley，Rosie - CAN”= Huntington-Whiteley，Rosie“）
逗号的第二个实例（即“Doe，John，CPA”=“Doe，John”）
空间的第二个实例（即“Doe，John Q”=“Doe，John”）
撇号前面或后面有一个空格（即“O'Leary，John”=“O'Leary，John”，但“Doe，John'US'”=“Doe，John”）
任何其他非字母字符（即“Doe，John：US”=“Doe，John”

提议的解决方案

此代码将满足上述所有条件，并将在末尾输出单个消息，表示无法找到文件夹的任何发件人（而不是每封电子邮件的单独消息）。它已经在Outlook 2013 / Windows 10上进行了测试。

<div class="green">
		<div id="green-grid-left">
			<div id="green-grid-left-description">Website problems?<br>
			We handle everything for you.</div>
		</div>
		<div id="green-grid-right">
			<div id="green-grid-right-description">Website problems?<br>
			We handle everything for you.</div>
		</div>
	</div>

Answer 3

更新文件夹名称Folders("Folder1")

Option Explicit
Sub File_olItems()
    Dim olNameSpace As Outlook.NameSpace
    Dim olSourceFolder As Outlook.Folder
    Dim olDestFolder As Outlook.Folder
    Dim currentExplorer As Explorer
    Dim Selection As Selection
    Dim olItem As MailItem
    Dim vItem As Variant
    Dim NameSender As String
    Dim i As Long

    Set olNameSpace = Application.GetNamespace("MAPI")
    Set currentExplorer = Application.ActiveExplorer
    Set Selection = currentExplorer.Selection
    Set olSourceFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders("Folder1")

    For Each olItem In Selection
        Set vItem = olItem

        If vItem.Class = olMail Then
            Debug.Print vItem.SentOnBehalfOfName
            NameSender = vItem.SentOnBehalfOfName

            If NameSender = ";" Then
                NameSender = vItem.SenderName
            End If

            If InStr(1, NameSender, "(", vbTextCompare) > 1 Then
                NameSender = Split(NameSender, "(")(0)
                Debug.Print NameSender
            End If

            On Error Resume Next
            Set olDestFolder = olSourceFolder.Folders(NameSender)

            If olDestFolder Is Nothing Then
                Set olDestFolder = olSourceFolder.Folders.Add(NameSender)
            End If

            vItem.Move olDestFolder
'           // count items moved
            i = i + 1
            Set olDestFolder = Nothing
        End If
    Next olItem

'   // Display the number of items that were moved.
    MsgBox "Moved " & i & " Mail Items."

    Set currentExplorer = Nothing
    Set olItem = Nothing
    Set Selection = Nothing
    Set olNameSpace = Nothing
    Set olSourceFolder = Nothing
End Sub

将邮件从发件人移动到发件人的文件夹名称

3 个答案:

假设

提议的解决方案