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
'-----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