I want to save all attachments from my Outlook 365 inbox.
Copying this tutorial I wrote:
Sub Download_Attachments()
Dim ns As NameSpace
Dim olFolder_Inbox As Folder
Dim olMail As MailItem
Dim olAttachment As Attachment
Dim fso As Object
Dim File_Saved_Folder As String
File_Saved_Folder_Path = "C:\GIS\temp\mails"
Set ns = GetNamespace("MAPI")
Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox)
Set fso = CreateObject("Scripting.FileSystemObject")
For Each olMail In olFolder_Inbox.Items
If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
fso.CreateFolder (fso.BuildPath(File_Saved_Folder_Path, Trim(olMail.Subject)))
For Each olAttachment In olMail.Attachments
olAttachment.SaveAsFile fso.BuildPath(File_Saved_Folder_Path, Trim(olMail.Subject)) & "\" & olAttachment.FileName
Next olAttachment
End If
Next olMail
Set olFolder_Inbox = Nothing
Set ns = Nothing
Set fso = Nothing
End Sub
When I execute the macro I get roughly (translated from Swedish):
Error 76, Cant find the path
The Subject property of the MailItem class and the FileName property of the Attachment class may contain forbidden symbols that can't be used for filenames. So. before calling the SaveAsFile method of the Attachment class you need to check the file path whether such folder exists and the path doesn't contain forbidden symbols. See What characters are forbidden in Windows and Linux directory names? for more information.
Related
This code saves the attachment from Outlook to a specific folder in my PC.
I need to move the selected mail in Outlook inbox to a folder in Outlook.
Ultimately, I will save the attachment and move this mail to a folder in Outlook.
Sub INC_Data()
Dim ol As Object 'Outlook.Application
Dim ns As Object 'Outlook.Namespace
Dim fol As Object 'Outlook.Folder
Dim i As Object
Dim mi As Object 'Outlook.MailItem
Dim at As Object 'Outlook.Attachment
Dim fso As Object 'Scripting.FileSystemObject
Dim dir As Object 'Scripting.Folder
Dim dirName As String
Dim oFSO As Object
Dim oFolder As Object
Dim oFile As Object
Dim f As Integer
'Some Set Ups
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set ol = CreateObject(Class:="Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set fol = ns.GetDefaultFolder(olFolderInbox)
'Finding the search item from Oulook Inbox
For Each i In fol.Items
If i.Class = 43 Then
Set mi = i
If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx#inc.ae") Then
dirName = "D:\XYZ "
If fso.FolderExists(dirName) Then
Set dir = fso.GetFolder(dirName)
Else
Set dir = fso.Createfolder(dirName)
End If
'Saving Attachment to a folder
For Each at In mi.Attachments
If Right(at.Filename, 4) = "xlsm" Then
at.SaveAsFile dir.Path & "\" & Range("Ad2").Text & ".xlsm"
End If
Next at
End If
End If
Next i
End Sub
First, delcare an object variable so that we can assign it the destination folder...
Dim olMoveToFolder As Object 'Outlook.Folder
Then, assign the destination folder to the variable. So, for example, depending on your folder structure, something like this...
Set olMoveToFolder = ns.Folders("Outlook").Folders("DestinationFolderName")
or
Set olMoveToFolder = fol.Folders("DestinationFolderName")
Then, add the following line, after saving the attachments, to move your email to the destination folder...
mi.Move olMoveToFolder
EDIT
While I haven't tested it, I have amended your macro to include the following...
The statement Option Explicit has been added to force the explicit
declaration of variables to help catch any potential errors. Note that
this statement must be place at the very top of the
module, before any procedure.
Some of the variable names have been renamed in the interest of
clarity.
The variable dir has been removed since it's not really needed,
and since it can be confused with the function Dir().
The variable dirName is set prior to looping through your mail
items.
The constant olFolderInbox has been replaced with the value 6,
since you are using late binding.
Here's your macro, amended accordingly...
Option Explicit
Sub INC_Data()
Dim ol As Object 'Outlook.Application
Dim ns As Object 'Outlook.Namespace
Dim inboxFol As Object 'Outlook.Folder
Dim moveToFolder As Object 'Outlook.Folder
Dim itm As Object
Dim mi As Object 'Outlook.MailItem
Dim att As Object 'Outlook.Attachment
Dim fso As Object 'Scripting.FileSystemObject
Dim dirName As String
'Some Set Ups
Set fso = CreateObject(Class:="Scripting.FileSystemObject")
Set ol = CreateObject(Class:="Outlook.Application")
Set ns = ol.GetNamespace("MAPI")
Set inboxFol = ns.GetDefaultFolder(6) 'olFolderInbox
Set moveToFolder = ns.Folders("MainFolderName").Folders("MoveToFolderName") 'change the folder names accordingly
dirName = "D:\XYZ"
If Not fso.FolderExists(dirName) Then
fso.CreateFolder dirName
End If
'Finding the search item from Oulook Inbox
For Each itm In inboxFol.Items
If itm.Class = 43 Then
Set mi = itm
If mi.Attachments.Count > 0 And InStr(mi.SenderEmailAddress, "xxxxxxx#inc.ae") Then
'Saving Attachments to a folder
For Each att In mi.Attachments
If Right(att.Filename, 4) = "xlsm" Then
att.SaveAsFile dirName & "\" & Range("Ad2").Text & ".xlsm"
End If
Next att
'Move mail item to destination folder
mi.Move moveToFolder
End If
End If
Next itm
End Sub
I'm trying to save Outlook emails into my H:Drive. I want it as a run a script rule but I can't get it to work. There are no attachments involved and all I need it is to save it as a .msg file. Please lmk if you find a different way to tackle this problem.
Thanks
Sub ExtractEmailToFolder2(itm As Outlook.MailItem)
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Folder File
Set fso = CreateObject("Scripting.FileSystemObject")
' loop to read email address from mail items.
For Each Mailobject In Folder.Items
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
Set objCopy = Mailobject.Copy
objCopy.SaveAs fldrpath & "\" & objCopy.Subject, olMSG
Next
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
First of all, there is no need to create a new Outlook Application instance (twice in your sample code!) if your VBA macro is run by the rule. Instead, you can use the global Application property:
Sub ExtractEmailToFolder2(itm As Outlook.MailItem)
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Create Folder if required
Set fso = CreateObject("Scripting.FileSystemObject")
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
itm.SaveAs fldrpath & "\" & "your_unique_filename.msg", olMSG
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
The sample code which is shown above saves the item against which the rule is run to the folder specified/hardcoded.
Problem:
Folder Check was included in the Loop
FileName had Subject in it. That always creates problem unless some kind of manipulation is done. Because it contains various characters that are not permitted in the Name of a File in Windows.
Note:
Put it in any Module in Outlook and Run using F5 or by Creating a Shortcut.
Try:
Sub ExtractEmailToFolder2()
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Dim Mailobject As Object
Dim Email As String
Dim NS As NameSpace
Dim Folder As MAPIFolder
Set OlApp = CreateObject("Outlook.Application")
Dim fso As Object
Dim fldrname As String
Dim fldrpath As String
' Setup Namespace
Set NS = ThisOutlookSession.Session
' Display select folder dialog
Set Folder = NS.PickFolder
' Create Folder File
Set fso = CreateObject("Scripting.FileSystemObject")
fldrpath = "H:\Backup stuff\"
If Not fso.folderexists(fldrpath) Then
fso.createfolder (fldrpath)
End If
' loop to read email address from mail items.
i = 1
For Each Mailobject In Folder.Items
Mailobject.SaveAs fldrpath & "\mail" & i & ".msg", olMsg
i = i + 1
Next
Set OlApp = Nothing
Set Mailobject = Nothing
End Sub
I am trying to access the sub folder by name "MacroEnabled" in Inbox, find all the attachments in it and save them to local drive.
I use this code to create a folder by name "Documents" and save the attachments. However while doing the second iteration it says file already exist error "58".
Dim ns As NameSpace
Dim olFolder_Inbox As Folder
Dim olMail As MailItem
Dim olAttachment As Attachment
Dim FolderPath As String
Dim fso As Object
Dim File_Saved As String
'email service type
Set ns = GetNamespace("MAPI")
Set olFolder_Inbox = ns.GetDefaultFolder(olFolderInbox).Folders("MacroEnabled")
Set fso = CreateObject("Scripting.FileSystemObject")
FolderPath = "Documents"
For Each olMail In olFolder_Inbox.Items
If TypeName(olMail) = "MailItem" And olMail.Attachments.Count > 0 Then
fso.CreateFolder ("Documents")
For Each olAttachment In olMail.Attachments
olAttachment.SaveAsFile fso.BuildPath(FolderPath, olAttachment.FileName)
Next olAttachment
End If
Next olMail
Set ns = Nothing
Set fso = Nothing
End Sub
First of all FolderPath should present whole path eg. FolderPath = "C:\Documents"
If you need you can use relative path for example FolderPath = CurrentProject.Path & "\Documents"
Then you can use FolderExisits method in loop by adding following instruction:
If Not fso.FolderExists(FolderPath) Then fso.CreateFolder (FolderPath )
For Each olMail In olFolder_Inbox.Items
fso.CreateFolder ("Documents_path")
look at this and try to check if folder Documents exists before creating another
To find all emails (by folder name i.e. email id) from subfolders of inbox present since last month and copy paste them in respective folders by their subject.
I am stuck at code NS = OlApp.GetNamespace("MAPIFolder") also with ("MAPI") as well the error of object variable not set is displaying
Dim OlApp As Outlook.Application
Set OlApp = New Outlook.Application
Set OlApp = CreateObject("Outlook.Application")
Dim fldrpath As String
Dim fldername As String
Dim oMail As Object
fldrpath = "\data\EMAILS\" & fldrname
Dim NS As Namespace
Dim Folder As MAPIFolder
Dim sName As String
Dim dtdate As String
Dim Inbox As MAPIFolder
NS = OlApp.GetNamespace("MAPIFolder")
Set Inbox = NS.GetDefaultFolder(olFolderInbox)
For Each mysubFolders In Inbox.subFolders
Set mysubfolder = Inbox.subFolders("PDI").Folders("OBU").Folders("DND")
For Each mailItems In mysubfolder
If oMail.Body = r Then
Set mailItems = oMail
sName = mailItems.Subject
dtdate = mailItems.ReceivedTime
Debug.Print fldrpath & sName
mailItems.SaveAs fldrpath & sName, olMSG
End If
Next
Set OlApp = Nothing
Set mailItems = Nothing
Next
End Sub
The first problem is this line, missing the Set keyword:
Set NS = OlApp.GetNamespace("MAPIFolder")
Then you are accessing "Inbox.subFolders", but there is no such property on a Folder object; it would be the Folders property collection that you want.
You also aren't using the mysubFolders variable in the loop, so that entire block of code is going to fail. There is also no explicit set of the mailItems object you are trying to iterate from the mysubfolder object.
I'd continue but frankly the entire method needs to be rewritten. Focus on ensuring you are declaring and setting the correct variables to the correct properties or objects.
I found this code on another website. It should take an email found in an Outlook folder and unzip the attachment. It uses a temporary location to do this.
I am using Outlook 2013 and the references I am using are: Visual Basic for Application, Microsoft Outlook 15.0 Object Library, OLE Automation, Microsoft Office 15.0 Object Library. I am running this code currently in a module.
Option Explicit
Sub Unzip1()
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As String
Dim msg As Outlook.MailItem
Dim ns As Outlook.NameSpace '
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("ASE")
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
FileNameFolder = Environ("USERPROFILE") & "Documents\"
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(Atchmt.FileName).Items
End If
Next
Next
End Sub
I am getting an error "Object variable or With block variable not set" on this line.
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(Atchmt.FileName).Items
I had to change
DIm oAPP as Object
to
Dim oApp as Shell
Early-binding using 'Microsoft Shell Controls and Automation'. Not sure why it was complaining about the late-binding
If we are talking about the Namespace class from the Outlook object mode, it doesn't provide the CopyHere method. The object itself provides methods for logging in and out, accessing storage objects directly by ID, accessing certain special default folders directly, and accessing data sources owned by other users. Use GetNamespace("MAPI") to return the Outlook NameSpace object from the Application object.
The CopyHere method copies an item or items to a folder. The item or items to copy should be passed as a parameter. This can be a string that represents a file name, a FolderItem object, or a FolderItems object. But not the attachment filename. You need to save the attachment on the disk first.
Make sure Sub Folder ("Books") in your Email Inbox Exist & "\Documents\Files\" that's where unzip files will be saved
Option Explicit
Sub Unzip1()
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As String
Dim msg As Outlook.MailItem
Dim ns As Outlook.NameSpace '
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Dim FileNameFolder As Variant
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("Books")
For Each msg In SubFolder.Items
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
FileNameFolder = Environ("USERPROFILE") & "\Documents\Files\"
Atchmt.SaveAsFile FileNameFolder
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace(FileNameFolder).CopyHere oApp.NameSpace(Atchmt.FileName).Items
End If
Next
Next
End Sub