[英]VBA to save attachments (based on defined criteria) from an email with multiple accounts
[英]VBA to loop through email attachments and save based on given criteria
這是對上一個問題的跟進( VBA 從具有多個帳戶的電子郵件中保存附件(基於定義的標准) )
場景:我有一個代碼,它遍歷某個 Outlook 帳戶中的所有電子郵件,並將附件保存到選定的文件夾中。 以前,我的問題是選擇從哪里提取附件的文件夾(和帳戶)(通過上一個問題的建議解決了這個問題)。
問題 1:代碼在該行顯示“類型不匹配”錯誤:
Set olMailItem = olFolder.Items(i)
問題 2:如問題標題所述,我的主要目標是遍歷所有附件並僅保存那些具有給定條件的附件(excel 文件,一個工作表名為“ASK”,一個名為“BID”)。 不僅僅是一個簡單的如果要考慮到這些標准,我必須將所有文件下載到“臨時文件夾”,進行選擇並將最終生成的文件放在輸出文件夾中,或者將所有文件下載到最終文件夾並刪除不符合標准。
問題:我似乎無法找到執行其中任何一個操作的方法。
問題:人們將如何做到這一點? 這兩者中的哪一個更有效?
代碼:
Sub email()
Application.ScreenUpdating = False
Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer
'delete content except from row 1
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.count).Delete
'set foldername and subject
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
'olSubject = ThisWorkbook.Worksheets("Control").Range("D16")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")
sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Set olNameSpace = olApp.GetNamespace("MAPI")
'check if folder is subfolder or not and choose olFolder accordingly
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
If (olFolder = "") Then
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
End If
'loop through mails
h = 2
For i = 1 To olFolder.Items.count
Set olMailItem = olFolder.Items(i)
'check if the search name is in the email subject
'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then
If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then
With olMailItem
strName = .Attachments.Item(j).DisplayName
'check if file already exists
If Not Dir(sPathstr & "\" & strName) = "" Then
.Attachments(j).SaveAsFile sPathstr & "\" & "(1)" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = "(1)" & strName
Else
.Attachments(j).SaveAsFile sPathstr & "\" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
End If
h = h + 1
Next
End With
End If
Next
Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"
End Sub
您的文件夾中可能有這樣的會議邀請或除普通郵件之外的其他內容。
檢查Item
的Class
屬性,看是否是olMail
我將在這里進行錯誤處理:
完整代碼:
Sub email_DGMS89()
Application.ScreenUpdating = False
Dim olApp As New Outlook.Application
Dim olNameSpace As Object
Dim olMailItem As Outlook.MailItem
Dim olFolder As Object
Dim olFolderName As String
Dim olAtt As Outlook.Attachments
Dim strName As String
Dim sPath As String
Dim i As Long
Dim j As Integer
Dim olSubject As String
Dim olSender As String
Dim sh As Worksheet
Dim LastRow As Integer
Dim TempFolder As String: TempFolder = VBA.Environ$("TEMP")
Dim wB As Excel.Workbook
'delete content except from row 1
ThisWorkbook.Worksheets("FileNames").Rows(2 & ":" & ThisWorkbook.Worksheets("FileNames").Rows.Count).Delete
'set foldername and subject
olFolderName = ThisWorkbook.Worksheets("Control").Range("D10")
'olSubject = ThisWorkbook.Worksheets("Control").Range("D16")
olSender = ThisWorkbook.Worksheets("Control").Range("D16")
sPath = Application.FileDialog(msoFileDialogFolderPicker).Show
sPathstr = Application.FileDialog(msoFileDialogFolderPicker).SelectedItems(1)
Set olNameSpace = olApp.GetNamespace("MAPI")
'check if folder is subfolder or not and choose olFolder accordingly
'Set olFolder = olNameSpace.GetDefaultFolder(olFolderInbox).Folders(olFolderName)
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
If (olFolder = "") Then
Set olFolder = olNameSpace.Folders("email@email.com").Folders("Inbox")
End If
'loop through mails
h = 2
For i = 1 To olFolder.items.Count
'''Const olMail = 43 (&H2B)
If olFolder.items(i).Class <> olMail Then
Else
Set olMailItem = olFolder.items(i)
'check if the search name is in the email subject
'If (InStr(1, olMailItem.Subject, olSubject, vbTextCompare) <> 0) Then
If (InStr(1, olMailItem.Sender, olSender, vbTextCompare) <> 0) Then
With olMailItem
For j = 1 To .Attachments.Count
strName = .Attachments.Item(j).DisplayName
'check if file already exists
If Not Dir(sPathstr & "\" & strName) = vbNullString Then
strName = "(1)" & strName
Else
End If
'''Save in temp
.Attachments(j).SaveAsFile TempFolder & "\" & strName
ThisWorkbook.Worksheets("FileNames").Range("A" & h) = strName
'''Open file as read only
Set wB = workbooks.Open(TempFolder & "\" & strName, True)
DoEvents
'''Start error handling
On Error Resume Next
Set sh = wB.sheets("ASK")
Set sh = wB.sheets("BID")
If Err.Number <> 0 Then
'''Error = At least one sheet is not detected
Else
'''No error = both sheets found
.Attachments(j).SaveAsFile sPathstr & "\" & strName
End If
Err.Clear
Set sh = Nothing
wB.Close
On Error GoTo 0
h = h + 1
Next j
End With
End If
End If
Next i
Application.ScreenUpdating = True
MsgBox "Download complete!", vbInformation + vbOKOnly, "Done"
End Sub
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.