[英]Using VBA to Automate - Save multiple attachment based on multiple criteria to specific folders
我根据以下标准向多个利益相关者（约 10 个）发送每日报告
以上所有都已尝试。 我还需要创建自动化，其中每个文件夹最多只能保存 2 个月的文件，之后将为这些月份的附件创建另一个文件夹。
我很欣赏我的代码很笨拙，需要一个更快的版本。
Option Explicit
Sub SaveOutlookAttachments()
Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.folder
Dim objItem As Object
Dim objMailItem As Outlook.MailItem
Dim objAttachment As Outlook.Attachment
'For Folders creation
Dim fso As Scripting.FileSystemObject
Dim dir As Scripting.Folders
Dim dirFolderName As String
'For Date settings
Dim iBackdate As Integer
' Hardcoding Partners -
Dim COMP_A_North As String
Dim COMP_A_South As String
Dim COMP_A_East As String
Dim COMP_A_West As String
Dim COMP_B As String
Dim COMP_C As String
Dim COMP_D As String
Dim COMP_E As String
Dim COMP_F As String
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")
Set fso = New Scripting.FileSystemObject
'Setting Partner Filters
COMP_A_North = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Scotland%'"
COMP_A_South = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%North%'"
COMP_A_East = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Midlands%'"
COMP_A_West = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compa%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%London%'"
COMP_B = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compb%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_C = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compc%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_D = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compd%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_E = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%compe%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
COMP_F = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@compf%'" & "AND
""urn:schemas:httpmail:subject"" LIKE '%Missing%'"
For Each objItem In objFolder.Items.Restrict(COMP_A_North)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa Report UpTo" &
Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compa North and Iceland Region Report" & Format(.ReceivedTime, "yyyy-
mm- dd") 'Put in a valid folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_A_South)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa Report
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime,
objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compa South Region Report" &
Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid folder location to
store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_A_East)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa Report
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compa East Region Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in
a valid folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_A_West)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "compa Report
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compa West and Central Region Report" & Format(.ReceivedTime, "yyyy-mm-
dd") 'Put in a valid folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_B)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompB Report
UpTo" & Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compb Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid
folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_C)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompC Report UpTo" &
Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "CompC Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid
folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_D)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompD Report UpTo" &
Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compd Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid
folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_E)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompE Report UpTo" &
Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compe Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid
folder location to store attachements
Next
End If
End If
End With
End If
Next
For Each objItem In objFolder.Items.Restrict(COMP_F)
'Check Item Class
If objItem.Class = Outlook.olMail Then
'Set as Mail Item
Set objMailItem = objItem
With objMailItem
Select Case Weekday(Now)
Case 7 ' Saturday: add extra day
iBackdate = 3
Case 1, 2, 3 ' Sunday through Tuesday: add extra 2 days
iBackdate = 4
Case Else ' Other days
iBackdate = 2
End Select
' Check date
If .ReceivedTime > DateAdd("d", -iBackdate, Now) Then
' Save Attachments
If objAttachment.Count > 0 Then
dirFolderName = "C:\Users\rootname\OneDrive\Desktop\VBATesting" & "CompF Report UpTo" &
Format(objAttachment.receivetime, "yyyy-mm")
If fso.FolderExists(dirFolderName) Then
Set dir = fso.GetFolder(dirFolderName)
Else
Set dir = fso.CreateFolder(dirFolderName)
End If
For Each objAttachment In .Attachments
Debug.Print objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
objAttachment.SaveAsFile "C:\Users\rootname\OneDrive\Desktop\VBATesting" &
objAttachment.FileName = "compf Report" & Format(.ReceivedTime, "yyyy-mm-dd") 'Put in a valid
folder location to store attachements
Next
End If
End If
End With
End If
Next
End Sub
这就是我如何重做这个。 已编译但未测试，因此如果它不起作用，您可能需要进行一些调试。
Sub SaveOutlookAttachments()
Dim objOutlook As New Outlook.Application
Dim objNamespace As Outlook.Namespace
Dim objFolder As Outlook.Folder
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set objFolder = objNamespace.Folders(1).Folders("Inbox")
ProcessMails objFolder, "compa", "Scotland", "compa Report UpTo", "compa Scotland Region Report"
ProcessMails objFolder, "compa", "North", "compa Report UpTo", "compa North Region Report"
ProcessMails objFolder, "compa", "Midlands", "compa Report UpTo", "compa Midlands Region Report"
ProcessMails objFolder, "compa", "London", "compa Report UpTo", "compa London Region Report"
End Sub
Sub ProcessMails(srcFolder As Outlook.Folder, compName As String, subj As String, _
saveFolder As String, saveFileName As String)
Const ROOT_FOLDER As String = "C:\Users\rootname\OneDrive\Desktop\VBATesting\"
Dim objItem As Object, objMailItem As Outlook.MailItem, dirFolderName As String
Dim objAttachment As Outlook.Attachment
For Each objItem In srcFolder.Items.Restrict(PFilter(compName, subj))
If objItem.Class = Outlook.olMail Then 'Check Item Class
Set objMailItem = objItem 'Set as Mail Item
If ProcessThisMail(objMailItem) Then
With objMailItem
dirFolderName = ROOT_FOLDER & saveFolder & _
Format(objMailItem.ReceivedTime, "yyyy-mm") & "\"
EnsureSaveFolder dirFolderName
Debug.Print "Message:", objMailItem.Sender, objMailItem.ReceivedTime, objMailItem.Subject
For Each objAttachment In .Attachments
Debug.Print , "Attachment:", objAttachment.Filename
objAttachment.SaveAsFile dirFolderName & _
saveFileName & Format(objMailItem.ReceivedTime, "yyyy-mm-dd")
Next
End With
End If 'processing this one
End If 'is a mail item
Next objItem
End Sub
'return a filter for company and subject
Function PFilter(sCompany, sSubj)
PFilter = "@SQL=""urn:schemas:httpmail:fromname"" LIKE '%@" & sCompany & "%'" & _
"AND ""urn:schemas:httpmail:subject"" LIKE '%" & sSubj & "%'"
End Function
'Abstract out the rules for when a mail is processed
Function ProcessThisMail(theMail As Outlook.MailItem) As Boolean
Dim iBackdate As Long
If theMail.Attachments.Count > 0 Then
Select Case Weekday(Now)
Case 7: iBackdate = 3 ' Saturday: add extra day
Case 1, 2, 3: iBackdate = 4 ' Sunday through Tuesday: add extra 2 days
Case Else: iBackdate = 2 ' Other days
End Select
If theMail.ReceivedTime > DateAdd("d", -iBackdate, Now) Then
ProcessThisMail = True 'will by default return false unless this line is reached
End If
End If
End Function
'ensure a subfolder exists
Sub EnsureSaveFolder(sPath As String)
With CreateObject("scripting.filesystemobject")
If Not .FolderExists(sPath) Then
.CreateFolder sPath
End If
End With
End Sub
VBA 从具有多个帐户的电子邮件中保存附件（基于定义的标准）
[英]VBA to save attachments (based on defined criteria) from an email with multiple accounts
声明:本站的技术帖子网页，遵循CC BY-SA 4.0协议，如果您需要转载，请注明本站网址或者原文地址。任何问题请咨询:yoyou2525@163.com.