I have some VBA which sometimes fails on the line Set Folder = Inbox.Folders("xxx") with the below error message.
Folder = Inbox.Folders is returning 0 folders even though I can see them in the the Outlook pane.
Run-time error '-2147221233 (8004010f)'
The attempted operation failed. An object could not be found.
Sub Export()
Select_Date.Show
'Dim OutlookApp As Outlook.Application
'Dim OutlookNamespace As NameSpace
'Dim Folder As MAPIFolder
'Dim OutlookMail As Variant
'Dim i As Integer
'Dim olNS As Outlook.NameSpace
'Dim Start_Date As Date
'Dim saveFolder As String
Start_Date = DateValue(Select_Date.ComboBox1.Value & " " & Select_Date.ComboBox2.Value & " " & Select_Date.ComboBox3.Value)
overwrite_flag = Select_Date.CheckBox1.Value
saveFolder = "K:\xxxx "
Set OutlookApp = New Outlook.Application
Set OutlookNamespace = OutlookApp.GetNamespace("MAPI")
Set objowner = OutlookNamespace.CreateRecipient("xx.xxx#xxx.com")
objowner.Resolve
Set Inbox = OutlookNamespace.GetSharedDefaultFolder(objowner, olFolderInbox)
'Set Folder_test = Inbox.Folders.GetLast
Set Folder = Inbox.Folders("xxx")
'Set Folder = Session.Folders("xxx").Folders("Inbox")
i = 1
For Each OutlookMail In Folder.Items
If TypeOf OutlookMail Is MailItem Then
If OutlookMail.ReceivedTime >= Start_Date And OutlookMail.Subject = "xxxx" Then
For Each attach In OutlookMail.Attachments
savename = saveFolder & Format(DateAdd("d", 35, OutlookMail.ReceivedTime), "yyyymmdd") & ".csv"
If (Dir$(savename) <> "") Then
If overwrite_flag = True Then
Kill savename ' delete if file exists
attach.SaveAsFile savename
End If
Else: attach.SaveAsFile savename
End If
attach.SaveAsFile savename
Next attach
End If
End If
i = i + 1
Next OutlookMail
Set Folder = Nothing
Set OutlookNamespace = Nothing
Set OutlookApp = Nothing
End Sub
You may try to iterate over all subfolders and find the required one by checking its name.
Also I've noticed that your code iterates over all items in the folder which is not really a good idea! Use the Find/FindNext or Restrict methods of the Items class. 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
The error is MAPI_E_NOT_FOUND, which means either the folder with that name does not exist, or that you have no access to its subfolders.
Also note that if shared folders are set to be cached, Outlook only caches the folder itself, but not its subfolders, hence you won't be able to access any subfolders.
Related
I have some experience with VBA in Excel, but taking my first steps in Outlook. I need to save all e-mail messages in a designated Outlook folder (Inbox\input) to disk (D:\myArchive\Email\) as .msg files and move mail item to archive folder in Outlook (Inbox\archive).
I have set up a mail rule in Outlook that moves mail to archive folder and runs a script below which actually does what I need. The problem is that I get mail rule error pop-ups occasionally and I struggle to track down the reason. Hence looking to turn away from Outlook mail rule and cycle through all folder contents "on-demand".
How could I convert it to cycle through Outlook folder as well as displace the mail item? Currently running Outlook 2019. Thanks!
edit: sorry, late clarification - target folder is in another mailbox (Office 365 shared mailbox). How to target a different account?
Public Sub saveEmailtoDisk(itm As Outlook.MailItem)
Dim saveFolder, msgName1, msgName2 As String
saveFolder = "D:\myArchive\Email\"
msgName1 = Replace(itm.Subject, ":", "")
msgName2 = Replace(msgName1, "/", "_")
itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
End Sub
The following code assumes that both the input and archive folders are located within the default inbox.
Public Sub saveAndArchiveInputEmails()
Dim saveFolder As String
saveFolder = "D:\myArchive\Email\"
Dim sourceFolder As Folder
Dim destFolder As Folder
With Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set sourceFolder = .Folders("input")
Set destFolder = .Folders("archive")
End With
Dim itm As Object
Dim i As Long
With sourceFolder
For i = .Items.Count To 1 Step -1
Set itm = .Items(i)
If TypeName(itm) = "MailItem" Then
saveEmailtoDisk saveFolder, itm
itm.Move destFolder
End If
Next i
End With
End Sub
Public Sub saveEmailtoDisk(ByRef saveFolder As String, ByVal itm As Object)
Dim msgName1, msgName2 As String
msgName1 = Replace(itm.Subject, ":", "")
msgName2 = Replace(msgName1, "/", "_")
itm.SaveAs saveFolder & msgName2 & ".msg", olMSG
End Sub
EDIT
For a shared mailbox, try the following instead...
With Application.GetNamespace("MAPI")
Dim sharedEmail As Recipient
Set sharedEmail = .CreateRecipient("someone#abc.com")
Dim sourceFolder As Folder
Set sourceFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("input")
Dim destFolder As Folder
Set destFolder = .GetSharedDefaultFolder(sharedEmail, olFolderInbox).Folders("archive")
End With
For your default inbox...
Dim myInbox As Folder
Set myInbox = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
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
Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")
A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders.Item(arrFolders(0))
If Not objFolder Is Nothing Then
For i = 1 To UBound(arrFolders)
Set colFolders = objFolder.Folders
Set objFolder = Nothing
Set objFolder = colFolders.Item(arrFolders(i))
If objFolder Is Nothing Then Exit For
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub