我想将邮件从发件人移动到我为发件人创建的文件夹.
SenderName显示为"Doe,John(US)",我的文件夹将是"Doe,John".
我需要做什么来将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
触发发件人姓名结尾的条件：
此代码将满足上述所有条件，并将在末尾输出一条消息，表示无法找到其文件夹的任何发件人（而不是为每封电子邮件发送一条单独的消息）。它已在 Outlook 2013/Windows 10 上进行了测试。
Public Sub MoveToFolder()
Dim objSelection As Selection
Set objSelection = Application.ActiveExplorer.Selection
Dim iSelected As Integer, iMoved As Integer
iSelected = objSelection.Count 'Get a total for output message
Dim StrOutput As String, StrUnmoved As String, StrName As String
StrUnmoved = "Unmoved Item Count by Sender" & vbNewLine & "============================"
Dim objNS As NameSpace
Dim objParentFolder As Folder, objSubFolder As Folder, objDestFolder As Folder
Dim BFound As Boolean, iLoc As Integer
Set objNS = Application.GetNamespace("MAPI")
Set objParentFolder = objNS.GetDefaultFolder(olFolderInbox)
'Only execute code if the parent folder has subfolders
If objParentFolder.Folders.Count > 0 Then
'Loop through all selected items
For Each Item In objSelection
If Item.Class = 43 Then
'This is an email.
BFound = False
StrName = GetSenderName(Item.SenderName)
For Each objSubFolder In objParentFolder.Folders
If objSubFolder.Folders.Count > 0 Then
On Error Resume Next
Set objDestFolder = Nothing
Set objDestFolder = objSubFolder.Folders(StrName)
On Error GoTo 0
If Not objDestFolder Is Nothing Then
'Folder found.
Item.Move objDestFolder
iMoved = iMoved + 1
BFound = True
Exit For
End If
End If
Next
If Not BFound Then
'Sender folder not found. Check if we have already logged this sender.
iLoc = 0
iLoc = InStr(1, StrUnmoved, StrName)
If iLoc > 0 Then
'Existing sender name. Increment current total.
StrUnmoved = Left(StrUnmoved, iLoc + Len(StrName) + 1) & _
Format(CInt(Mid(StrUnmoved, iLoc + Len(StrName) + 2, 5)) + 1, "00000") & Right(StrUnmoved, Len(StrUnmoved) - iLoc - Len(StrName) - 6)
Else
'New sender name.
StrUnmoved = StrUnmoved & vbNewLine & StrName & ": 00001"
End If
End If
End If
Next
If iMoved = iSelected Then
StrOutput = "All " & iSelected & " items moved to appropriate subfolders."
Else
'Remove extraneous zeroes
StrUnmoved = Replace(StrUnmoved, ": 000", ": ")
StrUnmoved = Replace(StrUnmoved, ": 00", ": ")
StrUnmoved = Replace(StrUnmoved, ": 0", ": ")
StrOutput = iMoved & "/" & iSelected & " items moved to appropriate subfolders; see below for unmoved details." & vbNewLine & vbNewLine & StrUnmoved
End If
MsgBox StrOutput
Else
MsgBox "There are no subfolders to the default inbox. Script will now exit."
End If
End Sub
Function GetSenderName(StrFullSender As String) As String
'Only take action if a non-null string is passed
If Len(StrFullSender) > 1 Then
StrFullSender = Trim(StrFullSender) 'Trim extraneous spaces
Dim StrOutput As String
'Find first case of the end of the name
Dim iChar As Integer
Dim iCommaCount As Integer
Dim iSpaceCount As Integer
For iChar = 1 To Len(StrFullSender)
Select Case Asc(Mid(StrFullSender, iChar, 1))
Case 65 To 90, 97 To 122 '192 to 246, 248 to 255 'Include 192-246 and 248-255 if you will receive emails from senders with accents or other symbols in their names
'No action necessary - this is a letter
Case 45, 151 'Hyphen or EM Dash - could be a hyphenated name
If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
'There is a space on one or both sides of the hyphen. This is a valid stop.
Case 44
iCommaCount = iCommaCount + 1
If iCommaCount > 1 Then Exit For
Case 32
iSpaceCount = iSpaceCount + 1
If iSpaceCount > 1 Then Exit For
Case 39
If Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1)) <> _
Trim(Mid(StrFullSender, IIf(iChar = 1, 1, iChar - 1), IIf(Len(StrFullSender) - iChar > 1, 3, Len(StrFullSender) - iChar + 1))) Then Exit For
'There is a space on one or both sides of the apostrophe. This is a valid stop.
Case Else
Exit For
End Select
Next
StrOutput = Trim(Left(StrFullSender, iChar - 1))
GetSenderName = StrOutput
End If
End Function