目标似乎是在调用时根据发件人姓名组织选定的邮件项目。
当没有选择移动任何项目时（即仅选择会议项目），可以将项目移动到所选文件夹内。
在选择要处理项目的文件夹时，该文件夹不能是主子文件夹或其子文件夹。
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
根据评论更新代码
在收件箱中搜索发件人姓名的所有子文件夹。如果找不到，则提示从文件夹选择器创建。
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
