Getting attachment from outlook using Access VBA - vba

I have a created folder in my outlook named "Reports". This folder contains emails with one attachment in each email. I would like to use ACCESS VBA to save the attachments from the "Reports" folder in Outlook to a local drive in my computer. here is the code I have so far, but gives me errors. Please help:
Sub GetAttachments()
Dim ns As NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim folder As Outlook.MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("Reports") // I get an error in this line says an object could not be found
i = 0
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Next Item

Is your Reports folder within your Inbox folder? You may need to do something like this:
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set RptFolder = Inbox.Folders("Reports")
Your syntax for saving attachments looks correct (apart from your comments not being correct for VBA). You could print out the Filename that you are creating to see if it's a valid name. And I assume that you have created the Automation folder that you mention.
Update:
Try declaring your Atmt as an Outlook.Attachment. There is such a thing as an Access.Attachment which does not have a SaveAsFile method, and it's probably picking that one up first. If you include the library name, you should get the one you need.
Update 2:
To get to your Reports folder, one way is to get the Inbox folder as you are currently doing, then get its parent, then get the Reports folder under that.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set Mailbox = Inbox.Parent
Set RptFolder = Mailbox.Folders("Reports")
Another way would be to scan the items under "ns" to find the one that starts with "Mailbox", then get the Reports folder under that. It seems a little more cumbersome than getting the parent of the inbox. That also seems cumbersome, but I couldn't find a way to get to the Mailbox folder directly.

Replace
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Atmt.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
With.....
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
FileName = "C:\Automation\" & Atmt.FileName
Attachments.SaveAsFile FileName // here is another error says method is not found
i = i + 1
Next Atmt
Outlook does not have a problem with atmt in the reference however, MS Access does. This should fix your problem.
Davis Rogers

Replace
Dim Atmt As Attachment
with
Dim Atmt As Outlook.Attachment
It'll make Access find the correct Class for atmt.

Related

save PDF attachment with filename &domain name

I would like to run a macro to do follow steps:
- save PDF only attachment to hard drive
- save it with a revise name filename & domain name.
Here is the code I search from open source and mix it together. any help is appreciated. thanks
Public Sub Download_Attachments()
Dim ns As NameSpace
Dim olFolder_Inbox As Folder
Dim olMail As MailItem
Dim olAttachment As Attachment
Dim strFolderPath As String
Dim strFileName As String
Dim strSenderAddress As String
Dim strSenderDomain As String
Dim fso As Object
strFolderPath = "C:\"
Set ns = GetNamespace("MAPI")
Set fso = CreateObject("Scripting.FileSystemObject")
Set olFolder_Inbox = Application.ActiveExplorer.CurrentFolder
Set olMail = Application.ActiveWindow.CurrentItem
'Get sender domain
strSenderAddress = olMail.SenderEmailAddress
strSenderDomain = Right(strSenderAddress, Len(strSenderAddress) - InStr(strSenderAddress, "#"))
For Each olMail In olFolder_Inbox.Items
If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
For Each olAttachment In olMail.Attachments
Select Case UCase(fso.GetExtensionName(olAttachment.FileName))
Case "PDF", "pdf"
olAttachment.SaveAsFile strFolderPath & strFileName
Case Else
'skip
End Select
Next olAttachment
End If
Next olMail
Set olFolder_Inbox = Nothing
Set fso = Nothing
Set ns = Nothing
End Sub
The following line of code retrieves the active folder in the Explorer window, not the Inbox one. Outlook can be started with any active folder, you can specify the folder name to the Outlook.exe file. To get the default folders (Inbox) you need to use the NameSpace.GetDefaultFolder method which returns a Folder object that represents the default folder of the requested type for the current profile; for example, obtains the default Calendar folder for the user who is currently logged on. For example, the following sample code uses the CurrentFolder property to change the displayed folder to the user's default Inbox folder.
Sub ChangeCurrentFolder()
Dim myNamespace As Outlook.NameSpace
Set myNamespace = Application.GetNamespace("MAPI")
Set Application.ActiveExplorer.CurrentFolder = myNamespace.GetDefaultFolder(olFolderInbox)
End Sub
Then it is not really recommended to iterate over all items in the folder.
For Each olMail In olFolder_Inbox.Items
Instead, you need to use the Find/FindNext or Restrict methods of the Items class to get only items that correspond to your conditions. Read more about these methods in the following articles:
How To: Use Find and FindNext methods to retrieve Outlook mail items from a folder (C#, VB.NET)
How To: Use Restrict method to retrieve Outlook mail items from a folder
Finally, the part you are interested in is the SaveAsFile method of the Attachment class which saves the attachment to the specified path:
olAttachment.SaveAsFile strFolderPath & domainName & strFileName
Make sure a qualified file path is passed as a parameter. I'd recommend running the code under the debugger and see what values are passed.

GetSharedDefaultFolder - Subfolder Access Error

I am having trouble getting my Outlook VBA code to recognize the subfolder in my Shared Tasks.
What I'm trying to do is create a macro that will automatically create a task in the department Shared Task folder. Tried Googling a variety of solutions to no avail. The code goes as follows:
Dim objApp As Outlook.Application
Dim defaultTasksFolder As Outlook.MAPIFolder
Dim subFolder As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace
Dim objMail As MailItem
Dim objItm As TaskItem
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
Set objMail = Outlook.Application.ActiveExplorer.Selection.Item(1)
Dim objOwner As Outlook.Recipient
Set objOwner = objNS.CreateRecipient("name#email.com")
objOwner.Resolve
If objOwner.Resolved Then
Set defaultTasksFolder = objNS.GetSharedDefaultFolder(objOwner, olFolderTasks)
subFolder = defaultTasksFolder.Folders("TestFolder") **ERROR OCCURS HERE - OBJECT COULD NOT BE FOUND**
Set objItm = subFolder.Items.Add(olTaskItem)
With objItm
.Subject = "Name- " & objMail.Subject
.StartDate = objMail.ReceivedTime
.Body = objMail.Body
End With
objItm.Save
MsgBox ("Task Created for e-mail: " & vbCrLf & objMail.Subject)
End If
End Sub
It errors out on subFolder = defaultTasksFolder.Folders("TestFolder"), saying that the object could not be found. I double and tripled checked the folder name.
Any ideas what might be causing this error? Thank you!!
First of all, add the Logon method before accessing MAPI, it will log to the profile if Outlook has just been started. If it is already running it will not affect anything. Then try to add both mailboxes as delegate stores (see the Advanced tab of the Exchange account properties dialog). You should see both mailboxes.
Finally, I'd try to iterate over all folders before to make sure the folder exists. Also, I'd recommend checking the recipient's name.
Keep in mind that Outlook might cache only the default folders, but not their suborders.
Can you see and access the subfolder in Outlook?

List all Email in folder using Outlook MAPI

I'd like to list all of my emails in a specific folder by using Outlook MAPI. I have tried the following code,
but it only shows 400 out of the 20,000 emails in the folder. I would greatly appreciate it if anyone could please show me how to list all of the emails.
Sub EmailListinFolder()
Dim mn As Long
Dim Message As String
Dim item As Object
Dim NS As Object
Dim Folder As Object
'Get the MAPI Name Space
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
'Allow the user to select a folder in Outlook
Set Folder = NS.PickFolder
For Each item In Folder.Items
If item.Class = olMail Then
Message = item.Subject & "|" & item.CreationTime
If Len(Message) Then
mn = mn + 1
End If
End If
Next item
MsgBox (mn)
End Sub
Is that an online profile? Most likely you end up opening too many items (for each loop keeps all items referenced until the loop exits). Use Table object instead - see example at https://msdn.microsoft.com/VBA/Outlook-VBA/articles/folder-gettable-method-outlook.

Run-time Error, Library not registered with macro importing attachments from outlook subfolders

I have the following code which I believe should work to save attachments from an Outlook subfolder to the specified path, before emptying the subfolder.
Sub Downloadattachments()
Dim applOutlook As Outlook.Application
Dim ns As Namespace
Dim inbox As MAPIFolder
Dim item As Object
Dim atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim SubFolder As MAPIFolder
Dim SubSubFolder As MAPIFolder
Dim VariableName As Name
Set ns = GetNamespace("MAPI")
Set inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = inbox.Folders("Paul")
Set SubSubFolder = SubFolder.Folders("Soja")
i = 0
If SubSubFolder.Items.Count = 0 Then
MsgBox
Else: End If
If SubSubFolder.Items.Count > 0 Then
For Each item In SubSubFolder.Items
For Each atmt In item.attachments
FileName = "\\homefolder5\bases" & atmt.FileName
atmt.SaveAsFile FileName
i = i + 1
item.Delete
Next atmt
Next item
End If
End Sub
Unfortunately I don't get past the line Set ns = GetNamespace("MAPI") before encountering the run-time error stating "Automation error: Library not registered". To clarify, I have the Microsoft Outlook 14.0 Object Library activated, along with other basic libraries. I think this must be something different.
I apologize if this is a really simple thing that I am overlooking, but I would appreciate whatever guidance you could give me!
Where do you run the VBA macro?
Dim applOutlook As Outlook.Application
It looks like you didn't initialize the applOutlook object in the code. If you develop an Outlook VBA macro, you can use the Application property:
Set applOutlook = Application
Set ns = applOutlook.GetNamespace("MAPI")
In case if you automate Outlook you need to create a new instance of the Application class. See How to automate Outlook from another program for more information.

For Each loop: Some items get skipped when looping through Outlook mailbox to delete items

I wanted to develop VBA code that:
Loops through all email items in mailbox
If there are any type of other items say "Calendar Invitation" skips that item.
Finds out the emails with attachments
If attached file has ".xml" extension and a specific title in it, saves it to a directory, if not it keeps searching
Puts all email includes .xml attachments to "Deleted Items" folder after doing step 4 and deletes all emails in that folder by looping.
Code works perfect EXCEPT;
For example
There are 8 email received with ".xml" file attached to each one of them in your mailbox.
run the code
you will see only 4 of the 8 items are processed successfully, other 4 remain in their positions.
If you run the code again, now there would be 2 items processed successfully and other 2 remain in your mailbox.
Problem: After running the code, it is supposed to process all files and deletes them all not the half of them in each run. I want it to process all items at a single run.
BTW, this code runs every time I open the Outlook.
Private Sub Application_Startup()
'Initializing Application_Startup forces the macros to be accessible from other offic apps
'Process XML emails
Dim InboxMsg As Object
Dim DeletedItems As Outlook.Folder
Dim MsgAttachment As Outlook.Attachment
Dim ns As Outlook.NameSpace
Dim Inbox As Outlook.Folder
Dim fPathTemp As String
Dim fPathXML_SEM As String
Dim fPathEmail_SEM As String
Dim i As Long
Dim xmlDoc As New MSXML2.DOMDocument60
Dim xmlTitle As MSXML2.IXMLDOMNode
Dim xmlSupNum As MSXML2.IXMLDOMNode
'Specify the folder where the attachments will be saved
fPathTemp = "some directory, doesn't matter"
fPathXML_SEM = "some directory, doesn't matter"
fPathEmail_SEM = "some directory, doesn't matter"
'Setup Outlook
Set ns = GetNamespace("MAPI")
Set Inbox = ns.Folders.Item("mailbox-name").Folders("Inbox")
Set DeletedItems = ns.Folders.Item("mailbox-name").Folders("Deleted Items")
'Loop through all Items in Inbox, find the xml attachements and process if they are the matching reponses
'On Error Resume Next
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
'Check for xml attachement
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
'Load XML and test for the title of the file
MsgAttachment.SaveAsFile fPathTemp & MsgAttachment.FileName
xmlDoc.Load fPathTemp & MsgAttachment.FileName
Set xmlTitle = xmlDoc.SelectSingleNode("//title")
Select Case xmlTitle.Text
Case "specific title"
'Get supplier number
Set xmlSupNum = xmlDoc.SelectSingleNode("//supplierNum")
'Save the XML to the correct folder
MsgAttachment.SaveAsFile fPathXML_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".xml"
'Save the email to the correct folder
InboxMsg.SaveAs fPathEmail_SEM & xmlSupNum.Text & "_" & Format(Date, "yyyy-mm-dd") & ".msg"
'Delete the message
InboxMsg.Move DeletedItems
Case Else
End Select
'Delete the temp file
On Error Resume Next
Kill fPathTemp & MsgAttachment.FileName
On Error GoTo 0
'Unload xmldoc
Set xmlDoc = Nothing
Set xmlTitle = Nothing
Set xmlSupNum = Nothing
End If
Next
End If
Next
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
'Clean-up
Set InboxMsg = Nothing
Set DeletedItems = Nothing
Set MsgAttachment = Nothing
Set ns = Nothing
Set Inbox = Nothing
i = 0
End Sub
Likely cause: When you do this InboxMsg.Move, all of the messages in your inbox after the one that was moved are bumped up by one position in the list. So you end up skipping some of them. This is a major annoyance with VBA's For Each construct (and it doesn't seem to be consistent either).
Likely solution: Replace
For Each InboxMsg In Inbox.Items
with
For i = Inbox.Items.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
This way you iterate backward from the end of the list. When you move a message to deleted items, then it doesn't matter when the following items in the list are bumped up by one, because you've already processed them anyway.
It's often not a good idea to modify the contents of a (sub)set of items while looping over them. You could modify your code so that it first identifies all of the items that need to be processed, and adds them to a Collection. Then process all the items in that collection.
Basically you shouldn't be removing items from the Inbox while you're looping through its contents. First collect all the items you want to process (in your Inbox loop), then when you're done looping, process that collection of items.
Here's some pseudo-code which demonstrates this:
Private Sub Application_Startup()
Dim collItems As New Collection
'Start by identifying messages of interest and add them to a collection
For Each InboxMsg In Inbox.Items
If InboxMsg.Class = olMail Then 'if it is a mail item
For Each MsgAttachment In InboxMsg.Attachments
If Right(MsgAttachment.DisplayName, 3) = "xml" Then
collItems.Add InboxMsg
Exit For
End If
Next
End If
Next
'now deal with the identified messages
For Each InboxMsg In collItems
ProcessMessage InboxMsg
Next InboxMsg
'Loop through deleted items and delete
For Each InboxMsg In DeletedItems.Items
InboxMsg.Delete
Next
End Sub
Sub ProcessMessage(InboxMsg As Object)
'deal with attachment(s) and delete message
End Sub