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
Related
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.
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 have emails in Outlook 2013, each with only one file attached called "Report.pdf".
I am trying to batch print all of the attachments from my selection of emails.
I found the below code which works if the attachments all have different names. Is it possible to amend this to print nearly 150 attachments which all have the same name?
The names of the reports don't matter, so feel free to add what you need to them inside the code.
Sub BatchPrintAllAttachmentsinMultipleEmails()
Dim objFileSystem As Object
Dim strTempFolder As String
Dim objSelection As Outlook.Selection
Dim objItem As Object
Dim objMail As Outlook.MailItem
Dim objAttachments As Outlook.Attachments
Dim objAttachment As Outlook.Attachment
Dim objShell As Object
Dim objTempFolder As Object
Dim objTempFolderItem As Object
Dim strFilePath As String
Dim DateFormat
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
strTempFolder = objFileSystem.GetSpecialFolder(2).Path & "\Temp for Attachments " & Format(Now, "YYYY-MM-DD_hh-mm-ss")
'Create a new temp folder
MkDir (strTempFolder)
Set objSelection = Outlook.Application.ActiveExplorer.Selection
For Each objItem In objSelection
If TypeOf objItem Is MailItem Then
Set objMail = objItem
Set objAttachments = objMail.Attachments
'Save all the attachments in the temp folder
For Each objAttachment In objAttachments
strFilePath = strTempFolder & "\" & objAttachment.FileName
objAttachment.SaveAsFile (strFilePath)
'Print all the files in the temp folder
Set objShell = CreateObject("Shell.Application")
Set objTempFolder = objShell.NameSpace(0)
Set objTempFolderItem = objTempFolder.ParseName(strFilePath)
objTempFolderItem.InvokeVerbEx ("print")
Next objAttachment
End If
Next
End Sub
You do not say why the code does not work if all the attachments have the same name. I assume it is because SaveAsFile wants to overwrite the last “Report.pdf” with the next “Report.pdf” before printing is finished.
My first thought was to add Kill strFilePath before the SaveAsFile. On reflection, I decided that would not work because Shell would still be printing the previous “Report.pdf” when you attempted to delete it.
I think the simplest approach would be:
Add
Dim Count as Long
to your Dims.
Replace strFilePath = strTempFolder & "\" & objAttachment.FileName by:
Count = Count + 1
strFilePath = strTempFolder & "\" & Count & objAttachment.FileName
This will create and print files named “1Report.pdf”, “2Report.pdf”, “3Report.pdf” and so on. I have used a prefix rather than the traditional suffix because it saves the bother of placing Count between the file name and the extension.
I assume you have some method of deleting all the attachments from the temporary folder.
I dragged an outlook msg to a specific folder named "email temp folder" and would like to reply on that msg automatically.
The title name of the msg which I saved in "email temp folder" could be anything. It is not possible for me to get the file's title name. So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
However, there is an error: object doesn't support this property or method on this line. .ReplyAll
How am I able to turn FileItemToUse into an outlook item?
Sub outlookActivate1()
Dim OutApp As Outlook.Application
Dim OutMail As Outlook.MailItem
Dim fso As New FileSystemObject
Dim objFolder As Object
Dim objFile As Object
Dim FileItemToUse As Object
Dim i As Long
Set OutApp = CreateObject("Outlook.Application")
strPath = "C:\Users\admin\Desktop\email temp folder" & "\"
strFiles = Dir(strPath & "*.*")
Set objFolder = fso.GetFolder(strPath)
For Each objFile In objFolder.Files
If i = 0 Then
Set FileItemToUse = objFile
End If
Next objFile
With FileItemToUse
.ReplyAll
.BCC = ""
.Subject = "Hi"
.HTMLBody = "testing"
.BodyFormat = olFormatHTML
.display
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Your code should look similar to the following:
Sub ReplyToFilesInFolder(SourceFolderName As String)
Dim FSO As Scripting.FileSystemObject
Dim SourceFolder As Scripting.Folder
Dim FileItem As Scripting.File
Dim strFile
Dim strFileType
Dim openMsg As MailItem
Dim strFolderpath As String
Set FSO = New Scripting.FileSystemObject
Set SourceFolder = FSO.GetFolder(SourceFolderName)
For Each FileItem In SourceFolder.Files
strFile = FileItem.name
' This code looks at the last 4 characters in a filename
' If we wanted more than .msg, we'd use Case Select statement
strFileType = LCase$(Right$(strFile, 4))
If strFileType = ".msg" Then
Debug.Print FileItem.Path
Set openMsg = Application.CreateItemFromTemplate(FileItem.Path)
' do whatever is needed to reply
openMsg.Close olDiscard
Set openMsg = Nothing
' end do whatever
End If
Next FileItem
Set FileItem = Nothing
Set SourceFolder = Nothing
Set FSO = Nothing
End Sub
This (untested) snipped was inspired by this article. Microsoft Scripting Runtime has to be included as project reference.
So I try to loop through the file in "email temp folder" and Set FileItemToUse = objFile
It is not possible to get the job done that way.
When you drag a message file (.msg) file to a specific folder the ItemAdd event is fired. So, you need to handle the event to get a MailItem object which corresponds a dropped file. Then you can use the Reply or ReplyAll methods.