Outlook VBA "The attempted operation failed" - vba

I have followed the instructions at http://www.rondebruin.nl/win/s1/outlook/saveatt.htm to save attachments from emails in a specific folder to another folder. When I run this code I get the error:
An unexpected error has occurred.
Please note and report the following information.
Macro Name: SaveEmailAttachmentsToFolder
Error Number: -2147221233
Error Description: The attempted operation failed. An object could
not be found.
New to macros, so don't know where the error may be. Any advice?
The code is below:
Sub Test()
SaveEmailAttachmentsToFolder "MyFolder", "xls", ""
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub

Community wiki. Answer is in a comment. Anyone finding this topic in a search will see there is an answer and is more likely to look in for a hopefully useful answer.
"The problem was that the folder I specified wasn't actually created within the Inbox, it was at the same level as the Inbox and so it couldn't find the folder. Simple things..." chinvpl

Related

Finding specific email Subject in Outlook sub folder and download attached files from the email

I have managed to make macro that downloads attachments files from my Inbox sub folder in Outlook, but it seems i can't make it works for specific combination of symbols in the email subject.
I need to download only the attachments from email that contains "906" in the Subject name. Can someone makes the modification i need for this task, please? I'm stuck already in my code :
Sub SaveMail()
SaveEmailAttachmentsToFolder "Meteologica SA Power Forecast", "csv", ""
End Sub
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As Object
Dim Att As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
Dim strAttachmentName As String
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
For Each item In SubFolder.Items
For Each Att In item.Attachments
If LCase(Right(Att.FileName, Len(ExtString))) = LCase(ExtString) And InStr(strAttachmentName, "906") > 0 Then
DestFolder = "C:\Users\Confi-005\OneDrive - confi.com\Desktop\Schedule\Mail_Temp\Download\"
FileName = DestFolder & item.SenderName & " " & Att.FileName
Att.SaveAsFile FileName
I = I + 1
End If
Next Att
Next item
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Iterating over all items in the folder is not really a good idea:
For Each item In SubFolder.Items
For Each Att In item.Attachments
Instead, you need to use the Find/FindNext or Restrict methods of the Items class where you can deal only with items that correspond to the specified search criteria. You may find these methods described in depth in the articles that I wrote for the technical blog:
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
For example, you may use the following search criteria to find items with a specific phrase in the Subject line:
criteria = "#SQL=" & Chr(34) _
& "urn:schemas:httpmail:subject" & Chr(34) _
& " ci_phrasematch 'question'"
Read more about that in the Filtering Items Using a String Comparison article.

Rule that runs code to save attachments turns off

This Run a Script code to save attachments stops saving attachments because the rule turns off.
Public Sub SaveAttachmentsToDisk(MItem As Outlook.MailItem)
Dim oAttachment As Outlook.Attachment
Dim sSaveFolder As String
sSaveFolder = "C:\Users\andra.aeras\Documents\Test\"
For Each oAttachment In MItem.Attachments
If Right(oAttachment.FileName, 4) = "xlsx" Then
oAttachment.SaveAsFile sSaveFolder & oAttachment.DisplayName
End If
Next
End Sub
Is there a way to "enable" the rules or improve this code to run properly or run without using rules?
Try it like this.
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As Namespace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim I As Integer
Dim wsh As Object
Dim fs As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
I = 0
' Check subfolder for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in this folder : " & OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
For Each Item In SubFolder.Items
For Each Atmt In Item.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString) Then
FileName = DestFolder & Item.SenderName & " " & Atmt.FileName
Atmt.SaveAsFile FileName
I = I + 1
End If
Next Atmt
Next Item
' Show this message when Finished
If I > 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Sub Test()
'Arg 1 = Folder name of folder inside your Inbox
'Arg 2 = File extension, "" is every file
'Arg 3 = Save folder, "C:\Users\Ron\test" or ""
' If you use "" it will create a date/time stamped folder for you in your "Documents" folder
' Note: If you use this "C:\Users\Ron\test" the folder must exist.
SaveEmailAttachmentsToFolder "MyFolder", "xls", ""
End Sub
Steps to follow:
1) Go to the VBA editor, Alt -F11
2) Tools>References in the Menu bar
3) Place a Checkmark before Microsoft Outlook ? Object Library
? is the Outlook version number
4) Insert>Module
5) Paste the code (two macros) in this module
6) Alt q to close the editor
7) Save the file

Loop through outlook unread emails not working

I am having trouble getting this loop to work. Any advice?
Sub SaveEmailAttachmentsToFolder(OutlookFolderInInbox As String, _
ExtString As String, DestFolder As String)
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim Item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim MyDocPath As String
Dim i As Integer
Dim wsh As Object
Dim fs As Object
Dim InboxMsg As Object
On Error GoTo ThisMacro_err
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders(OutlookFolderInInbox)
'To fix my issue I may have to change the loop to repeat the same number of
times as attachments
' Check subfolder for messages and exit of none found
' strFilter = "[Unread] = True"
' Set inboxItems =
ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)
If SubFolder.UnReadItemCount = 0 Then
MsgBox "There are no New messages in this folder : " &
OutlookFolderInInbox, _
vbInformation, "Nothing Found"
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Exit Sub
End If
'Create DestFolder if DestFolder = ""
If DestFolder = "" Then
Set wsh = CreateObject("WScript.Shell")
Set fs = CreateObject("Scripting.FileSystemObject")
MyDocPath = wsh.SpecialFolders.Item("mydocuments")
DestFolder = MyDocPath & "\" & Format(Now, "dd-mmm-yyyy hh-mm-ss")
If Not fs.FolderExists(DestFolder) Then
fs.CreateFolder DestFolder
End If
End If
If Right(DestFolder, 1) <> "\" Then
DestFolder = DestFolder & "\"
End If
' Check each message for attachments and extensions
strFilter = "[Unread] = True"
Set inboxItems =
ns.GetDefaultFolder(olFolderInbox).Folders(OutlookFolderInInbox).Items.Restrict(strFilter)
' For Each Item In inboxItems
For i = inboxItems.Count To 1 Step -1 'Iterates from the end backwards
Set InboxMsg = Inbox.Items(i)
'For Each Item In inboxItems
' For Each Atmt In inboxItems(I).Attachments
For Each Atmt In InboxMsg.Attachments
If LCase(Right(Atmt.FileName, Len(ExtString))) = LCase(ExtString)
Then
FileName = DestFolder & Format(Item.ReceivedTime, "yyyy-mmm-dd") & Atmt.FileName
Atmt.SaveAsFile FileName
End If
Item.UnRead = "False"
' inboxItems(I).UnRead = "False"
Next Atmt
' Item.UnRead = "false"
Next
' Show this message when Finished
If i = 0 Then
MsgBox "You can find the files here : " _
& DestFolder, vbInformation, "Finished!"
Else
MsgBox "No attached files in your mail.", vbInformation, "Finished!"
End If
' Clear memory
ThisMacro_exit:
Set SubFolder = Nothing
Set Inbox = Nothing
Set ns = Nothing
Set fs = Nothing
Set wsh = Nothing
Exit Sub
' Error information
ThisMacro_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveEmailAttachmentsToFolder" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume ThisMacro_exit
End Sub
Here is Quick example, set filter for both UnRead & Items with Attachments
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Dim Inbox As Outlook.MAPIFolder
Dim Items As Outlook.Items
Dim i As Long
Dim Filter As String
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Filter = "#SQL=" & Chr(34) & "urn:schemas:httpmail:hasattachment" & _
Chr(34) & "=1 AND " & _
Chr(34) & "urn:schemas:httpmail:read" & _
Chr(34) & "=0"
Set Items = Inbox.Items.Restrict(Filter)
For i = Items.Count To 1 Step -1
Debug.Print Items(i) 'Immediate Window
Next
End Sub

Adding an Appointment sent as an Attachment to a Calendar

Automated emails with .ics attachments are being received in an Outlook Shared mailbox.
I am trying to open that attachment, and save that Meeting/Appointment to the Calendar.
I tried a number of ways. For my latest iteration I am hoping to add this macro directly on the Shared Calendar's mailbox. Let me know if it makes more sense for the emails to be sent to my personal Outlook mailbox, where I then call the macro from a "run a script" Outlook Rule, and route it to the Shared Calendar.
Sub SaveAttatchments()
' This Outlook macro checks at the Outlook Inbox for messages
' with attached files (of *.ics type) and put a entry in the calendar.
On Error GoTo SaveAttachments_err
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim mynamespace As Outlook.NameSpace
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set mynamespace = Application.GetNamespace("MAPI")
Set InboxFolder = mynamespace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = mynamespace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "ics" Then
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myMtgReq = mynamespace.OpenSharedFolder(FileName)
myMtgReq.GetAssociatedAppointment (True)
i = i + 1
End If
Next Atmt
Next Item
SaveAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub
I get the following:
"Outlook cannot perform this action on this type of attachment."
Below is the corrected vba. The Attachment saves as a AppointmentItem, not a MeetingItem, which was causing the issues.
Sub SaveAttatchments()
On Error GoTo SaveAttachments_err
Dim myNameSpace As Outlook.NameSpace
Dim InboxFolder As Outlook.Folder
Dim myCalendarFolder As Outlook.Folder
Dim myMtgReq As Outlook.MeetingItem
Dim myAppt As Outlook.AppointmentItem
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Set myNameSpace = Application.GetNamespace("MAPI")
Set InboxFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myCalendarFolder = myNameSpace.GetDefaultFolder(olFolderCalendar)
FilePath = "C:\temp\"
' Check each message for attachments
For Each Item In InboxFolder.Items
If Item.Subject = "Conf Calendar" Then
For Each Atmt In Item.Attachments
'Save the attachment in folder
FileName = FilePath & Atmt.FileName
Atmt.SaveAsFile FileName
'Import the ics from the folder and put an entry in Calendar
Set myAppt = myNameSpace.OpenSharedItem(FileName)
myAppt.Save
i = i + 1
Next Atmt
End If
Next Item
' Clear memory
SaveAttachments_exit:
Set Atmt = Nothing
Set Item= Nothing
Set myMtgReq = Nothing
Exit Sub
SaveAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: SaveAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachments_exit
End Sub

VBA Outlook rule to Run Script is not completing

I'm have trouble with this macro/script that doesn't completely run via email rule
I have an outlook rule that looks for an email with a subject then move the email to a subfolder then runs a script that move the email attachment to a folder on the C drive and then deletes the original email from the subfolder
Everything seem to be setup correctly, security is ok, and the macro runs as a macro outside the rule It's just the rule doesn't run the script, here is the script I'm using
Sub Get_SOH_All(MyMail As MailItem)
On Error GoTo SaveAttachmentsToFolder_err
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim SubFolder As MAPIFolder
Dim item As Object
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim varResponse As VbMsgBoxResult
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("DATA DUMP") ' Enter correct subfolder name.
i = 0
If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then
MkDir "c:\DATA DUMP\Stock On Hand"
End If
For Each item In SubFolder.Items
For Each Atmt In item.Attachments
If Right(Atmt.FileName, 3) = "csv" Then
FileName = "C:\DATA DUMP\Stock On Hand\"
Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv"
item.Delete
i = i + 1
End If
Next Atmt
Next item
SaveAttachmentsToFolder_exit:
Set Atmt = Nothing
Set item = Nothing
Set ns = Nothing
Exit Sub
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information to Jarrod Hall." _
& vbCrLf & "Macro Name: GetAttachmentsSOH" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub
The code in a script is normally used on one item not multiple.
The mail is to be deleted so you can drop the part of the rule that moves the mail and try this.
Sub Get_SOH_All(MyMail As MailItem)
On Error GoTo SaveAttachmentsToFolder_err
Dim Atmt As Attachment
Dim FileName As String
If Len(Dir("c:\DATA DUMP\Stock On Hand", vbDirectory)) = 0 Then
MkDir "c:\DATA DUMP\Stock On Hand"
End If
For Each Atmt In MyMail.Attachments
If Right(Atmt.FileName, 3) = "csv" Then
FileName = "C:\DATA DUMP\Stock On Hand\"
Atmt.SaveAsFile FileName & "Stock_On_Hand_All.csv"
MyMail.Delete
End If
Next Atmt
SaveAttachmentsToFolder_exit:
Set MyMail = Nothing
Exit Sub
SaveAttachmentsToFolder_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information to Jarrod Hall." _
& vbCrLf & "Macro Name: GetAttachmentsSOH" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume SaveAttachmentsToFolder_exit
End Sub