-
Feb 8th, 2018, 03:20 PM
#1
Thread Starter
Hyperactive Member
download email attachments based on the subject line and folder names from a worksht
I got a list of email attachements which i need to download from different folders of outlook in a excel sheet in the below order.
data is in range Row 2 to 10 but can be more in future
Column A: File / attachment name
Column B: Email Subject Line
Column C: Outlook Folder Name
Column D: Save as location for attachements (different for each)
Now I have below function which I got through google search which I want to use, below is what i have put together so far, also I want to add the subject line and filename as string (since I want to name the attachment as its mentioned in the worksheet while saving) which is missing in the function:
Code:
Sub Downloademailattachments ()
Dim x As Integer
Dim Attachmentname As String
Dim Outlookfolder As String
Dim Subjectline As String
Dim Filesaveaspath As String
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A2").Select
For x = 1 To NumRows
Attachmentname = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,1)).Value
Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,2)).Value
Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
Filesaveaspath = ThisWorkbook.Sheets("Sheet1").Range(Cells(x,3)).Value
SaveEmailAttachmentsToFolder Outlookfolder, "xls", Filesaveaspath
ActiveCell.Offset(1, 0).Select
Next
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
-
Feb 9th, 2018, 06:44 AM
#2
Re: download email attachments based on the subject line and folder names from a work
from the code it appears it should save all .xls attachments, but does not in anyway use the attachment file name in column A
depending on the number of emails in outlook folders there may be much better ways than looping all the folder items, you can use the items.restrict method, to limit the number of items to match the subject line
Code:
set sitems = subfolder.items.restrict("[subject]='" & subj & "'")
For Each Item In sitems
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
where subj is an additional parameter to the function, from the calling procedure
ActiveCell.Offset(1, 0).Select
there is no need for this line
also it would be better not to create an instance of outlook for every line in the worksheet, better to just have one instance and use the for all iterations
i believe i would just integrate the function in to the main procedure, though you could open an outlook instance in the main procedure, then pass the outlook subfolder to the function
Last edited by westconn1; Feb 9th, 2018 at 06:50 AM.
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 9th, 2018, 04:19 PM
#3
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
ok. I have made the below changes, but where do i capture the Outlook folder name since its not just one outlook folder we need to loop through different outlook folder and download the attachments and rather than looping through every folder, it's better to look into the folders which are listed in the column C, also how can we make sure that we download only the most recent date attachements from the folders since the mails with same subject are received daily.
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim Outlookfolder As String
Dim Subjectline As String
Dim DestFolder As String
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
Range("A2").Select
For x = 1 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
Outlookfolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
Set sitems = subfolder.items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.Filename, Len(ExtString))) = LCase(ExtString) Then
Filename = DestFolder & Atmt.Filename
Atmt.SaveAsFile Filename
I = I + 1
End If
Next Atmt
Next Item
Next
End Sub
-
Feb 9th, 2018, 09:20 PM
#4
Re: download email attachments based on the subject line and folder names from a work
i made some changes to your procedure, i also noted that you do not have an outlook application object, so possibly some of the original code was written in outlook, for the outlook variables to be valid would require a reference to outlook, else change the variables to object, i have not tested the code as posted, so may contain some typo or code error, i fixed or changed anything i noticed that did not look right,
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 2)).Value
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 3)).Value
DestFolder = ThisWorkbook.Sheets("Sheet1").Range(Cells(x, 4)).Value
ExtString = ".xls"
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
'if destfolder does not have a trailing \ then one would need to be appended to the path
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 12th, 2018, 01:48 PM
#5
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
Ok. i had to make a small tweak and it works now, the only thing is that if i have to download the files with multiple extensions at one go then how do i add the same to the code. for e.g. i have *.csv, *.xls, *.txt and *.xml this four extension file type attachments are expected then how can we include the same.
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Filter = "[Unread] = True"
Set Items = olFolder.Items.Restrict(Filter)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Atmt.FileName
'if destfolder does not have a trailing \ then one would need to be appended to the path
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub]
Last edited by abhay_547; Feb 12th, 2018 at 01:58 PM.
-
Feb 12th, 2018, 03:29 PM
#6
Re: download email attachments based on the subject line and folder names from a work
change attachment loop like
Code:
For Each Atmt In Item.Attachments
select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
case ".xls", ".csv", ".pdf", ".xlsx"
FileName = DestFolder & Atmt.FileName
'if destfolder does not have a trailing \ then one would need to be appended to the path
Atmt.SaveAsFile FileName
I = I + 1
End select
Next Atmt
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 14th, 2018, 02:52 AM
#7
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
Ok. I have replaced the above piece of code but now it doesn't working and doesn't show any error msg as well. I checked if the destination folder is ending with "\" and it is ending with "\" and everything else is same but it's not working, apart from this i have also tried to declare the extn case as string because i don't want to hardcode the extensions but it didn't work so i have commented it out for now.
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A1", Range("A1").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 1 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
'ExtString = ".xls" 'include other extensions .i.e. *.csv, *.xml, *.txt
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
For Each Atmt In Item.Attachments
select case LCase(Right(Atmt.FileName, instr(atmt.filename, ".")))
' dim fileextn As string
'fileextn = ThisWorkbook.Sheets("Sheet1").Range("B2").value ' cell B2 will have the text ".xls", ".csv", ".pdf", ".xlsx"
'case fileextn
case ".xls", ".csv", ".pdf", ".xlsx"
FileName = DestFolder & Atmt.FileName
'if destfolder does not have a trailing \ then one would need to be appended to the path
Atmt.SaveAsFile FileName
I = I + 1
End select
Next Atmt
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub]
-
Feb 14th, 2018, 05:13 AM
#8
Re: download email attachments based on the subject line and folder names from a work
i screwed up the right statement,
decided mid is better anyway
this only partial code to show the changes
Code:
extstring = ".xlsx, .csv, .txt," 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.Restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
For Each atmt In Item.Attachments
fext = Mid(atmt.FileName, InStrRev(atmt.FileName, "."))
Select Case True
Case InStr(extstring, fext & ",")
FileName = DestFolder & atmt.FileName
atmt.SaveAsFile FileName
i = i + 1 ' i am not sure what the counter is used for
End Select
Next atmt
Next Item
i changed the select case to use variable, this should now allow a multiple filetype string, needs to have a comma or someother separator character, immediately after each fileextn (including the last)
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 14th, 2018, 08:41 AM
#9
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
Thanks a lot. it's working now, but the only issue is that if the subject line of the email don't have the date then it may end up downloading previous day attachment. see below 2 examples.
Email subject line 1: Account Balances COB 02/13/2018 (in this case, i have applied a formula in the subject line column (column B) concatenating text and date .i.e. Account balance COB and today minus 1
Email subject line 2: Outstanding Dues (this mail subject line doesn't have the date so in this case its the same every day and if i expect this mail 10am everyday then i will go ahead and run it at 10.05am everyday so if the mail has not yet arrived then it will download previous day mail attachment.
To tackle this issue, i am planning to include a column called Mail Date (Column E) and formulate it with expected date .i.e. if its yesterday COB then today minus 1 and it comes in 2 days then today -2 will take workday to avoid weekend's, so how can we refer the macro to this mail date column
and i want to include also a column at the end (Column F) as Download Status, if the file gets downloaded then it will get populated with the text "File Downloaded Successfully" and if not then it will get populated with the text "Email not found". for error, i was trying to include the below errhandler but believe i am not adding it in the right place, hence its not working. can you advise.
Code:
On Error Goto Errhandler
ErrHandler:
ThisWorkbook.Sheets("Sheet1").cells(x,6).value = "Email Not found"
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
On Error GoTo ErrHandler
For Each Atmt In Item.Attachments
fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
Select Case True
Case InStr(extstring, fext & ",")
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1 ' i am not sure what the counter is used for
End Select
Next Atmt
ErrHandler:
ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub
-
Feb 14th, 2018, 03:35 PM
#10
Re: download email attachments based on the subject line and folder names from a work
you could use some flag to indicate if the mail has already been processed
also message properties have a sentdate you could possibly make use of
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 15th, 2018, 03:12 PM
#11
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
Ok. thanks. should it be something like below.. also can you help with the error handler. thanks again
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
On Error GoTo ErrHandler
If item.receivedtime = MailDate then
For Each Atmt In Item.Attachments
fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
Select Case True
Case InStr(extstring, fext & ",")
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1 ' i am not sure what the counter is used for
End Select
Next Atmt
ErrHandler:
ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
Else
End if
End Sub
-
Feb 15th, 2018, 03:21 PM
#12
Re: download email attachments based on the subject line and folder names from a work
If item.receivedtime = MailDate then
looks like you need an end if somewhere, after next atmt?
errhandler will run every time regardless of whether there is an error, so all rows will show email not found
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
-
Feb 15th, 2018, 04:28 PM
#13
Thread Starter
Hyperactive Member
Re: download email attachments based on the subject line and folder names from a work
ok. I have updated it for received time. where should i move the errhandler then.
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
For x = 5 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
On Error GoTo ErrHandler
If item.receivedtime = MailDate then
For Each Atmt In Item.Attachments
fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
Select Case True
Case InStr(extstring, fext & ",")
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1 ' i am not sure what the counter is used for
End Select
Next Atmt
Else
End if
ErrHandler:
ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Email Not found"
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub
-
Feb 16th, 2018, 06:13 AM
#14
Re: download email attachments based on the subject line and folder names from a work
think in this case i would use in-line error handling, for each email
Code:
Sub Downloademailattachments()
Dim x As Integer
Dim OutlookfolderInInbox As String
Dim Subjectline As String
Dim DestFolder As String
Dim MailDate As String
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Set olook = CreateObject("outlook.application")
Set ns = olook.GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
NumRows = Range("A5", Range("A5").End(xlDown)).Rows.Count
' if you want to start at row 2, change to for x = 2 to numrows
On Error resume next
For x = 5 To NumRows
Subjectline = ThisWorkbook.Sheets("Sheet1").Cells(x, 2)
OutlookfolderInInbox = ThisWorkbook.Sheets("Sheet1").Cells(x, 3)
DestFolder = ThisWorkbook.Sheets("Sheet1").Cells(x, 4)
MailDate = ThisWorkbook.Sheets("Sheet1").Cells(x, 5)
extstring = ThisWorkbook.Sheets("Sheet1").Range("B2").Value 'include other extensions .i.e. *.csv, *.xml, *.txt or get from some cell
Set SubFolder = Inbox.Folders(OutlookfolderInInbox)
Set sitems = SubFolder.Items.restrict("[subject]='" & Subjectline & "'")
For Each Item In sitems
If item.receivedtime = MailDate then
For Each Atmt In Item.Attachments
fext = Mid(Atmt.FileName, InStrRev(Atmt.FileName, "."))
Select Case True
Case InStr(extstring, fext & ",")
FileName = DestFolder & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1 ' i am not sure what the counter is used for
End Select
Next Atmt
Else
End if
if not err.number = 0 then
ThisWorkbook.Sheets("Sheet1").Cells(x, 6).Value = "Some error occurred"
err.clear
end if
Next Item
Next x
Set Inbox = Nothing
Set ns = Nothing
' olook.quit 'if required
Set olook = Nothing
End Sub
this should work ok for any error saving the attachments, and allows the code to continue for next rows, but does nothing for other parts of the code so i moved the on error forward to encompass finding the outlook folder as well, some separate error handler may be good for the setting the outlook objects as without them nothing will work
i do my best to test code works before i post it, but sometimes am unable to do so for some reason, and usually say so if this is the case.
Note code snippets posted are just that and do not include error handling that is required in real world applications, but avoid On Error Resume Next
dim all variables as required as often i have done so elsewhere in my code but only posted the relevant part
come back and mark your original post as resolved if your problem is fixed
pete
Tags for this Thread
Posting Permissions
- You may not post new threads
- You may not post replies
- You may not post attachments
- You may not edit your posts
-
Forum Rules
|
Click Here to Expand Forum to Full Width
|