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
Related
I have a macro to create a folder for each e-mail containing attachments and store it's attachments.
I would like an existing Word document to be copied to every new folder created.
I tried fileCopy, but I can't make it work since the target is variable.
Option Explicit
Sub Application_Startup()
Dim ol As Outlook.Application
Dim ns As Outlook.Namespace
Dim fol As Outlook.Folder
Dim i As Object
Dim mi As Outlook.MailItem
Dim at As Outlook.Attachment
Dim rootfol As Outlook.Folder
Dim fso As Scripting.FileSystemObject
Dim dir As Scripting.Folder
Dim dirName As String
Set fso = New Scripting.FileSystemObject
Set ol = New Outlook.Application
Set ns = ol.GetNamespace("MAPI")
Set rootfol = ns.Folders(1)
Set fol = rootfol.Folders("boîte de réception").Folders("test")
For Each i In fol.Items
If i.Class = olMail Then
Set mi = i
If mi.Attachments.Count > 0 Then
dirName = "C:\Users\chadi\OneDrive\Documents\VBA\" & Format(mi.ReceivedTime, "yyyy-mm-dd hh-nn-ss ") & Left(Replace(mi.Subject, ":", ""), 20)
If fso.FolderExists(dirName) Then
Set dir = fso.GetFolder(dirName)
Else
Set dir = fso.CreateFolder(dirName)
End If
For Each at In mi.Attachments
at.SaveAsFile dir.Path & "\" & at.Filename
Next at
End If
End If
Next i
End Sub
Maybe someone else can give you a better answer without needing more information but I need you to be more specific about the variability of this file because I cannot answer your question with VBA code.
I also do not see FileCopy anywhere in your example.
[ EDIT ]
I commented out the file selection and added new code that should work with the new information you provided.
[ IMPORTANT ] I assume you are using Windows. You need to Shift Right Click on your Word document and select Copy As Path. Then you need to paste the path in the new code to completely replace [paste the path here] If you do it correctly it should look something like like mySpecialWordDocument = "C:\MyDirectory\MyFiles\MyFile.docx"
If fso.FolderExists(dirName) Then
Set dir = fso.GetFolder(dirName)
Else
Set dir = fso.CreateFolder(dirName)
'With Application.FileDialog(msoFileDialogFilePicker)
'.AllowMultiSelect = False
'.Filters.Clear
'If .Show Then fso.CopyFile .SelectedItems(1), dirName & "\" & Split(.SelectedItems(1), "\")(UBound(Split(.SelectedItems(1), "\")))
'End With
Dim mySpecialWordDocument as String
mySpecialWordDocument= [paste the path here]
fso.CopyFile mySpecialWordDocument, dirName & "\" & Split(mySpecialWordDocument, "\")(UBound(Split(mySpecialWordDocument, "\")))
End If
It opens a dialog window for the user to select a file and copies that file into the new folder.
For me to answer the question you asked, you need to tell me how you manually decide which file to select.
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'm trying to extract an zip file from my Outlook mail.
Below is my script but its throwing an error object variable or with block variable not set.
On
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
How I fix it.
Sub Unzip()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Atchmt As Attachment
Dim FileName As String
Dim msg As Outlook.MailItem
Dim FileNameFolder As String
Dim FSO As Object 'variables for unzipping
Dim oApp As Object
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("TEST")
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
MsgBox "1"
FileNameFolder = "C:\Users\xxxx\Documents\test\"
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
End If
Next
End If
End If
Next
End Sub
Try saving the zip file first then extract it, if you want to delete the zip file then try Kill (zippath & zipname )
Dim TempFile As String
For Each msg In SubFolder.Items
If msg.UnRead = True Then
If LCase(msg.Subject) Like "*motor*" Then
For Each Atchmt In msg.Attachments
If (Right(Atchmt.FileName, 3) = "zip") Then
' MsgBox "1"
FileNameFolder = "C:\Temp\Folders\"
Debug.Print FileNameFolder ' Immediate Window
Debug.Print Atchmt.FileName ' Immediate Window
TempFile = FileNameFolder & Atchmt.FileName
Atchmt.SaveAsFile TempFile
Set oApp = CreateObject("Shell.Application")
oApp.NameSpace((FileNameFolder)).CopyHere oApp.NameSpace((Atchmt.FileName)).Items
Kill (TempFile)
End If
Next
End If
End If
Next
Declare msg as a generic Object - you can have objects other than MailItem in the Inbox, such as ReportItem or MeetingItem.