Outlook VBA - Error 424 Object Required error - but I can't work out why - vba

We get hundreds of invoices emailed in per day - all are PDF format, and for most members of my dept, they're doing nothing more than marking them as read and moving them to a folder. My folder is called "invoices" and is a subfolder to my Inbox. I have written the following code, it throws an error 424 on the lines:
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
All I'm trying to do is check if an email is unread and has a pdf attachment, then move it to my "invoices" folder. Code follows:
Sub Lazy()
On Error GoTo Lazy_err
' Declare the variables
Dim ns As NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim Item As Object
Dim Atmt As Attachment
Dim i As Integer
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("invoices")
i = 0
' If statement to check if there's any unread emails in the box
If Inbox.UnReadItemCount = 0 Then
MsgBox "There are no unread messages in your Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
For Each Item In Inbox.Items
If Item.UnRead = True Then
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "pdf" Then
myItem.Move myDestFolder
Item.UnRead = False
i = i + 1
End If
Next Atmt
' close off If statements, then move to next item and start again
End If
Next Item
' Display a summary message!
If i > 0 Then
MsgBox "I found " & i & " emails." _
& vbCrLf & "I have moved them into the correct folder." _
& vbCrLf & vbCrLf & "Maybe double check to make sure nothing else has been moved?", vbInformation, "Finished!"
Else
MsgBox "There's nothing to find", vbInformation, _
"Finished!"
End If
' Housekeeping - reset everything for next time macro is run
Lazy_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
' Exit the macro :)
Exit Sub
' Error Handler - goes at very end of script, even after "exit sub"
Lazy_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 Lazy_exit
End Sub

First of all, you need to correct the namespace variable name as Paul suggested:
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = ns.GetDefaultFolder(olFolderInbox)
Then I have noticed the following lines of code:
For Each Item In Inbox.Items
If Item.UnRead = True Then
Don't iterate over all items in the folder. It will take a lot of time and may cause issues related to not releasing objects in time. Use the Find/FindNext or Restrict methods of the Items class instead. You can 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

You have created/initialized a Namespace Object variable ns, but not myNameSpace. Make sure you modify your code to reference appropriate objects.
Sub Lazy()
On Error GoTo Lazy_err
' Declare the variables
Dim ns As NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim Item As Object
Dim Atmt As Attachment
Dim i As Integer
' Set variables
Set ns = GetNamespace("MAPI")
Set myInbox = ns.GetDefaultFolder(olFolderInbox)
'Code continues...

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.

Error creating Outlook Task Item in Sub-folder of Task folder

I've been using a routine that I discovered on Stack Overflow to automatically create a task item in Outlook in the default Tasks folder. I attempted to modify it to create the task in one of two sub-folders of Tasks named "New FTEs" and "New Consultants".
Running this code results in this message from the error handler.
Error Number: -2147221233
Error Source: AddOlkTask
Error Description: The attempted operation failed. An object could not be found.
The problem code is shown between 'start new code and 'end new code. I've tried many variants of this code, but I can't crack it (no pun intended).
Sub AddOlTask(sSubject, sBody, dtDueDate, dtReminderDate, name, program)
On Error GoTo Error_Handler
Dim noDue, pFolder, reminderSetFlag As String
reminderSetFlag = False
If program <> "Career Path Curriculum" Then
dtDue = dtDueDate
dtReminder = dtReminderDate
reminderSetFlag = True
End If
If program = "Active Consultant" Then
pFolder = "New Consultants"
Else
pFolder = "New FTEs"
End If
Const olTaskItem = 3
Dim olApp As Object
Dim OlTask As Object
Set olApp = CreateObject("Outlook.Application")
Set OlTask = olApp.CreateItem(olTaskItem)
With OlTask
.Subject = name & ": " & sSubject
.Status = 1 '0=not started, 1=in progress, 2=complete, 3=waiting,
'4=deferred
.Importance = 1 '0=low, 1=normal, 2=high
.dueDate = dtDue
.ReminderSet = reminderSetFlag
.ReminderTime = dtReminder
.Categories = "Mandatory SkillSoft Training" 'use any of the predefined Categorys or create your own
.body = sBody
.Display
.Save
End With
'start new code
Dim objNS As Outlook.NameSpace
Dim olFolder As Outlook.MAPIFolder
Dim tsk As Outlook.TaskItem
Set olApp = Outlook.Application
Set objNS = olApp.GetNamespace("MAPI")
Set olFolder = objNS.GetDefaultFolder(olFolderTasks)
Set olFolder = olFolder.Folders(pFolder) 'error raised on this line
'end new code
Error_Handler_Exit:
On Error Resume Next
Set OlTask = Nothing
Set olApp = Nothing
Exit Sub
Error_Handler:
MsgBox "The following error has occured" & vbCrLf & vbCrLf & "Error Number: " & _
Err.Number & vbCrLf & "Error Source: AddOlkTask" & vbCrLf & "Error Description: " & _
Err.Description, vbCritical, "An Error has Occurred!"
Resume Error_Handler_Exit
End Sub
I had a similar problem and perhaps the cause of your problem is the same. I discovered the default Inbox was not in the store into which all my emails were loaded from my ISP. The default Inbox was in fact empty because it had never been used.
Run the macro below to discover what default folders you have and which store contains them.
Sub DsplUsernameOfDefaultStores()
Dim NS As Outlook.NameSpace
Dim DefaultFldr As MAPIFolder
Dim FldrTypeNo() As Variant
Dim FldrTypeName() As Variant
Dim InxFldr As Long
Set NS = CreateObject("Outlook.Application").GetNamespace("MAPI")
FldrTypeNo = VBA.Array(olFolderCalendar, olFolderConflicts, olFolderContacts, _
olFolderDeletedItems, olFolderDrafts, olFolderInbox, _
olFolderJournal, olFolderJunk, olFolderLocalFailures, _
olFolderManagedEmail, olFolderNotes, olFolderOutbox, _
olFolderSentMail, olFolderServerFailures, _
olFolderSuggestedContacts, olFolderSyncIssues, olFolderTasks, _
olPublicFoldersAllPublicFolders, olFolderRssFeeds)
FldrTypeName = VBA.Array("Calendar", "Conflicts", "Contacts", _
"DeletedItems", "Drafts", "Inbox", _
"Journal", "Junk", "LocalFailures", _
"ManagedEmail", "Notes", "Outbox", _
"SentMail", "ServerFailures", _
"SuggestedContacts", "SyncIssues", "Tasks", _
"AllPublicFolders", "RssFeeds")
Debug.Print "Stores containing default folders"
For InxFldr = 0 To UBound(FldrTypeNo)
Set DefaultFldr = Nothing
On Error Resume Next
Set DefaultFldr = NS.GetDefaultFolder(FldrTypeNo(InxFldr))
On Error GoTo 0
If DefaultFldr Is Nothing Then
Debug.Print "No default " & FldrTypeName(InxFldr)
Else
Debug.Print "Default " & FldrTypeName(InxFldr) & " in """ & DefaultFldr.Parent.Name & """"
End If
Next
End Sub
Second attempt at identifying the problem
I have added two sub-folders to my Tasks folders and then used the following macro to successfully display their names.
I have used Session instead of GetNamespace("MAPI"). These are supposed to be equivalent but I have once had Session work when GetNamespace("MAPI") did not. I don't remember the details and I did not investigate since I was happy to use Session.
You will need to amend my Set Fldr ... statement if your Tasks folder is not in the same location as mine. You can use Set Fldr = Session.GetDefaultFolder(olFolderTasks) if you prefer.
I have displayed the names with square brackets round them to highlight any stray spaces within the name.
Sub DsplTaskFolders()
Dim Fldr As Folder
Dim InxTskFldrCrnt
Set Fldr = Session.Folders("Outlook data file").Folders("Tasks")
For InxTskFldrCrnt = 1 To Fldr.Folders.Count
Debug.Print "[" & Fldr.Folders(InxTskFldrCrnt).Name & "]"
Next
End Sub
Thanks again Tony. You're code helped me understand the issue. I was not creating the custom folders in the correct location in Outlook. I created then under Inbox, when I should have created them under Tasks. The difference is not obvious. You basically have to right-click on the object Tasks - username#domain.com and select Create New Folder. If you right-click somewhere else, for instance, on the To-Do List, you'll create the folder under Inbox. It's working now.

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

Items.restrict method to look for items that are sent today

I'm trying to write a code to download weekly assignments (attachments) and save it to a folder.
I got a code which goes through every item and downloads all the attachments but it goes from latest to earliest date. I need the latest one as the earlier attachments will overwrite the later ones.
I added a restrict method to look for items that are sent today but it still goes through the whole inbox.
Sub downloadAttachment()
Dim ns As NameSpace
Dim Inbox As MAPIFolder
Dim Item As Object
Dim myItems As Items
Dim Atmt As Attachment
Dim FileName As String
Dim i As Integer
Dim sFilter As String
'Setting variable for inbox.
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
**sFilter = "[ReceivedTime]>=""&Date()12:00am&"""
Set myItems = Inbox.Items.Restrict(sFilter)**
i = 0
'Error handling.
On Error GoTo downloadattachment_err
'if no attachments, msgbox displays.
If Inbox.Items.Count = 0 Then
MsgBox "There are no messages in the Inbox.", vbInformation, _
"Nothing Found"
Exit Sub
End If
'Goes through each item in inbox for attachments.
For Each Item In Inbox.Items
For Each Atmt In Item.Attachments
If Right(Atmt.FileName, 3) = "txt" Then
FileName = "C:\losscontroldbases\pendingworkdownload\" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
End If
Next Atmt
Next Item
'If attachments found, the displays message.
If i > 0 Then
MsgBox "I found " & i & " attached files." _
& vbCrLf & "I have saved them into the C:\losscontroldbases\pendingworkdownload." _
& vbCrLf & "Have a nice day!"
Else
MsgBox "I didn't find any attached files in your mail."
End If
'Clearing memory.
downloadattachment_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
'Error handling code.
downloadattachment_err:
MsgBox " An unexpected error has occured."
End Sub
Your code references "date" string as a literal value. Use something like
Filter = "[ReceivedTime]>= '" & CStr(Date()) & " 12:00am' "

Saving Outlook Attachments

working with VBA in Outlook and am struggling with levelled folders when locating as it seems to only work a one levelled 'sub level'. I currently have probably a 5 tier folder organisation in my outlook, and daily I will get many emails which have attachments that need to be filed.
So far I'm working with my first folder to extract attachments and file them in a designated folder I have made but it wont work as the subfolder is in the 4th tier.
Sub GetAttachments()
On Error GoTo GetAttachments_err
' Declare variables
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
Set ns = GetNamespace("MAPI")
Set Inbox = ns.GetDefaultFolder(olFolderInbox)
Set SubFolder = Inbox.Folders("DZ1")
i = 0
' Check Inbox for messages and exit of none found
If SubFolder.Items.Count = 0 Then
MsgBox "There are no messages in the Sales Reports folder." _
, vbInformation, "Nothing Found"
Exit Sub
End If
' Check each message for attachments
If SubFolder.Items.Count > 0 Then
For Each Item In SubFolder.Items
' Save any attachments found
For Each Atmt In Item.Attachments
FileName = "File path" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
End If
' Clear memory
GetAttachments_exit:
Set Atmt = Nothing
Set Item = Nothing
Set ns = Nothing
Exit Sub
' Handle errors
GetAttachments_err:
MsgBox "An unexpected error has occurred." _
& vbCrLf & "Please note and report the following information." _
& vbCrLf & "Macro Name: GetAttachments" _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume GetAttachments_exit
End Sub
Can I please get some help?
Cheers
You need to refactor your code so that the operations that are performed in a folder is in a recursive method that calls itself when it needs to access another folder in the folder's Folder.Folders collection.
Follow the path as if you were getting the folder manually.
Set SubFolder = Inbox.Folders("DZ1").Folders("DZ2").Folders("DZ3").Folders("DZ4")
just searching subfolders will reeally only check direct subfolders. not "grandchildren".
You would have to do something like:
Sub subfolderrs_6_levels()
Dim Ol, Mf, Mf1, mf2, Ns, mf3, mf4, mf5, mf6, I&
On Error Resume Next
For Each Mf In Ns.Folders
call_your_routine(mf)
I = I + 1
For Each Mf1 In Mf.Folders
call_your_routine(mf1)
I = I + 1
For Each mf2 In Mf1.Folders
call_your_routine(mf2)
I = I + 1
For Each mf3 In mf2.Folders
call_your_routine(mf3)
I = I + 1
For Each mf4 In mf3.Folders
call_your_routine(mf4)
I = I + 1
For Each mf5 In mf4.Folders
call_your_routine(mf5)
I = I + 1
For Each mf6 In mf5.Folders
call_your_routine(mf6)
Next
Next
Next
Next
Next
Next
Next
Set Ns = Nothing: Set Mf1 = Nothing: Set Mf = Nothing: Set Ol = Nothing:
Set mf2 = Nothing: Set mf3 = Nothing: Set mf4 = Nothing: Set mf5 = Nothing: Set mf6 = Nothing
End Sub
sub call_your_routine(mf as Outlook.folder)
For Each Item In SubFolder.Items
' Save any attachments found
For Each Atmt In Item.Attachments
FileName = "File path" & Atmt.FileName
Atmt.SaveAsFile FileName
i = i + 1
Next Atmt
Next Item
end sub