PDA

View Full Version : [SOLVED] Getting Attachments from Outlook with Excel VBA



JrTraylor3
11-23-2016, 04:40 PM
I have been trying to work with Outlook and Excel VBA the last couple weeks. I have the 3 versions of code below that allow me to find a specific attachment (cell value) and place it into a shared folder on a server. I would like to first search outlook for a specific subfolder then find the attachment, if it does not exist I want to search the inbox and all subfolders for the attachment. The reason I am trying to do it this way is strictly for how fast the code executes. Some people using this procedure will have a rule for moving emails to a specific folder some people will not. The code runs much faster when it has less emails to look through to find the attachment so looking for the specific folder first will make the people who do this most often happier.

'-----Looks through the inbox-----

Sub GetAttachmentFromInbox()
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Atmt.FileName = Range("CORPONo").Value Then
FileName = Range("COFolder").Value & "\" & Atmt.FileName
MsgBox FileName
Atmt.SaveAsFile FileName
Exit Sub
End If
Next Atmt
Next Item

End Sub

'-----Looks Through all Subfolders-----

Sub GetAttachmentfromAllFolders2()
Dim olApp As Outlook.Application
Dim olNs As Outlook.Namespace
Dim olFolder As Outlook.MAPIFolder
Dim eFolder As Outlook.Folder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String

Set olApp = New Outlook.Application
Set olNs = olApp.GetNamespace("MAPI")
For Each eFolder In olNs.GetDefaultFolder(olFolderInbox).Folders
Set olFolder = olNs.GetDefaultFolder(olFolderInbox).Folders(eFolder.Name)
For Each Item In eFolder.Items
For Each Atmt In Item.Attachments
If Atmt.FileName = Range("CORPONo").Value Then
FileName = Range("COFolder").Value & "\" & Atmt.FileName
MsgBox FileName
Atmt.SaveAsFile FileName
Exit Sub
End If
Next Atmt
Next Item
Set olFolder = Nothing
Next eFolder
End Sub

'-----Look through a specific folder-----

Sub GetAttachemntsTest()
Dim ns As Namespace
Dim Inbox As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Outlook.Attachment
Dim FileName As String

Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("LOCUS ENERGY")

For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Atmt.FileName = Range("CORPONo").Value Then
FileName = Range("COFolder").Value & "\" & Atmt.FileName
MsgBox FileName
Atmt.SaveAsFile FileName
Exit Sub
End If
Next Atmt
Next Item

End Sub

Leith Ross
11-23-2016, 08:34 PM
Hello JrTraylor3,

Did you have a specific question or is this post to share your findings with others?

JrTraylor3
11-24-2016, 01:31 AM
Sorry I guess I should have separated the question after stating what I have and it probably could have been asked better. This was what I was asking poorly.

I would like to first search outlook for a specific subfolder then find the attachment, if it does not exist I want to search the inbox and all subfolders for the attachment. The reason I am trying to do it this way is strictly for how fast the code executes. Some people using this procedure will have a rule for moving emails to a specific folder some people will not. The code runs much faster when it has less emails to look through to find the attachment so looking for the specific folder first will make the people who do this most often happier.

So, how can I search outlook for a specific subfolder, if the folder does not exist continue searching the inbox and all subfolders until it is found to find a specific attachment like in the 3 versions of code above?

snb
11-24-2016, 04:43 AM
It depends of whether you want to run the code in Outlook or from another application (Word, Excel, Powerpoint. e.g.)

JrTraylor3
11-24-2016, 11:01 AM
It is being run from Excel. The attachment name will be determined based on a value entered into a cell. The code I have listed references 2 named ranges that need to be part of my code.

A user is filling out a form in Excel, That form has a button that currently creates a folder directory on our server, saves the file based on values entered into named ranges in the folder, then sends an email to specific users with a hyperlink to the file. It also creates a hyperlink for a file that is manually transferred from an email into the created folder. I added 2 of the versions of code together (look in inbox and look in subfolders) so that I can find the attachment automatically and add it to the same code but it takes a little more time than what I would like. The people that will be using this process will most likely have a rule in place to put emails in a subfolder. So I came up with the code to search in a specific folder (that executes real fast as there is not as much email in that folder).

Then I realized if someone else is ever asked to run this process they wont be able to, so I tried to teach myself how to use the .Find method to find the subfolder and add it to an if statement so that if it is not found then search all other folders but could not get it to work.

The code that I need to add to is listed below.


Sub CreateFolderandSaveFile()
Dim wb As Workbook
Dim ws As Worksheet
Dim suffix, suffix1, fName, fName1, fName2, fpath, As String,
Set wb = ThisWorkbook
Set ws = ThisWorkbook.Sheets("Change Order Report")
Set ws2 = ThisWorkbook.Sheets("Hidden For VBA")
If Range("CORCODesc") = "" Then
MsgBox "Please enter a general description for this Change Order"
Range("CORCODesc").Select
Exit Sub
Else
'Do Nothing
End If
If Range("CORProjectNo") = "" Then
MsgBox "Please enter a Project Number"
Range("CORProjectNo").Select
Exit Sub
Else
'Do Nothing
End If
If Range("CORCONo") = "" Then
MsgBox "Please enter a Change Order Number"
Range("CORCONo").Select
Exit Sub
Else
'Do Nothing
End If
For Each Cell In Range("Directory")
If Cell = "" Then
'do nothing
ElseIf Len(Dir(Cell, vbDirectory)) = 0 Then
MkDir Cell
End If
Next Cell
suffix = ".xlsm"
suffix1 = ".pdf"
fpath = Range("COFolder") & "\"
fName = Range("CORProjectNo") & " CO-" & Range("CORCONo") & " " & Range("CORCODesc") _
& " Qty. " & Range("CORLine1Qty") & " COReportBA"
fName1 = fpath + fName + suffix
fName2 = fpath & Range("CORCustPONo") + suffix1
wb.SaveAs fName1, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
strbody = "font size=""3"" face=""Calibri"">" & _
"Hello :br B" & _
fName & "/B COR has been created.<br>" & _
"Click " & _
"A HREF=""file://" & fName1 & _
"""HereA" & _
" to open the live file." & _
"brClick " & _
"A HREF ""file://" & fName2 & _
"""Her</A>" & _
" to open the PO." & _
"<br><br>A copy of the COR has also been attached." & _
"<br><br><br>Regards," & _
"<br><br>Sales</font>"
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = "A New Change Order Report has been Entered for job " & Range("CORProjectNo")
.HTMLBody = strbody
.Attachments.Add fName1
'You can add other files also like this
'.Attachments.Add ("C:\test.txt")
.Send
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
End Sub