Move selected items to folder - vba

I am using the below function to move selected emails to another folder.
The error says "An object could not be found."
It works the first time, but any subsequent attempts fail on the line:
Set TestFolder = SubFolders.Item(FoldersArray(i))
When the following line executes, when I expand folders in the watch window, no subfolders appear:
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
I am calling the function from a sub:
Option Explicit
Private Item As Object, olkItem As Object
Private AutoReply As String
Private myDestFolder As Outlook.Folder, myInbox As Outlook.Folder
Private myNameSpace As Outlook.NameSpace
Sub ReplywithNote2()
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = GetFolder("\\PO_Queries\Inbox\Completed")
For Each olkItem In Application.ActiveExplorer.Selection
With olkItem
If .Class = olMail Then
'.Move myDestFolder
End If
End With
Next
End Sub
Function:
Function GetFolder(ByVal FolderPath As String) As Outlook.Folder
Set GetFolder = Nothing
Dim TestFolder As Outlook.Folder
Dim FoldersArray As Variant
Dim i As Integer
'On Error GoTo GetFolder_Error
If Left(FolderPath, 2) = "\\" Then
FolderPath = Right(FolderPath, Len(FolderPath) - 2)
End If
'Convert folderpath to array
FoldersArray = Split(FolderPath, "\")
Set TestFolder = Application.Session.Folders.Item(FoldersArray(0))
If Not TestFolder Is Nothing Then
For i = 1 To UBound(FoldersArray, 1)
Dim SubFolders As Outlook.Folders
Set SubFolders = TestFolder.Folders
Set TestFolder = SubFolders.Item(FoldersArray(i))
If TestFolder Is Nothing Then
Set GetFolder = Nothing
End If
Next
End If
'Return the TestFolder
Set GetFolder = TestFolder
On Error GoTo 0
Exit Function
GetFolder_Error:
Set GetFolder = Nothing
Exit Function
End Function
When I restart Outlook it works. I tried setting several variables to Nothing, executing 'End' in the hope of resetting the relevant variable. What is reset when I restart Outlook?
Edit - I've narrowed it down to the move line. The problem occurs when running the sub after having moved the item.

For Each does not work correctly when moving or deleting.
You either process item one until there are no items left or loop backwards.
For i = Application.ActiveExplorer.Selection.Count to 1 step -1
https://msdn.microsoft.com/en-us/library/office/ff863343%28v=office.15%29.aspx
"To delete all items in the Items collection of a folder, you must delete each item starting with the last item in the folder. For example, in the items collection of a folder, AllItems, if there are n number of items in the folder, start deleting the item at AllItems.Item(n), decrementing the index each time until you delete AllItems.Item(1)."
Edit: 2015 06 16
Unless there is a reason for using GetFolder try this:
Set myDestFolder = myNameSpace.Folders("PO_Queries").Folders("Inbox").Folders("Completed")

Many thanks to niton, I amended my sub to the following, which works:
Sub ReplywithNote2()
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = GetFolder("\\PO_Queries\Inbox\Completed")
For i = Application.ActiveExplorer.Selection.Count To 1 Step -1
With Application.ActiveExplorer.Selection.Item(i)
If .Class = olMail Then
.Move myDestFolder
End If
End With
Next
End Sub
The issue still occurs if I move the email back into the original folder manually and try again, but I can live with that!
Thanks again, most grateful.

Sub myMove()
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = GetFolder("\\xxx\folder1\folder2\folder3")
Dim i As Long
For Each olkItem In Application.ActiveExplorer.Selection
i = MsgBox("Do you want to move selected emails to folder folder3?", vbYesNo + vbQuestion + vbSystemModal + vbMsgBoxSetForeground, "Confirm Move")
If i = vbNo Then
Cancel = True
End
Else
'Continue moving message
For i = Application.ActiveExplorer.Selection.Count To 1 Step -1
With Application.ActiveExplorer.Selection.Item(i)
If .Class = olMail Then
.Move myDestFolder
End If
End With
Next
End
End If
Next
End:
End Sub

Related

Set mails read if they were read in another folder

I'm trying to make an outlook macro, which will 'update' the mails. I have an Inbox folder and an another one. (2 mail accunts)
There is a rule, which is copying the mail from another folder to my inbox.
My goal is to set the mail as read in another folder, if it was read in the Inbox folder.
Sub precitane()
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
Dim mydeffolder As Outlook.Folder
Dim items As Object
Dim defitems As Object
Set myNameSpace = Application.GetNamespace("MAPI")
Set myDestFolder = myNameSpace.Folders("") 'mymail
Set mydeffolder = myNameSpace.GetDefaultFolder(olFolderInbox)
For Each items In myDestFolder.items
For Each defitems In mydeffolder.items
If TypeOf items Is Outlook.MailItem & TypeOf defitems Is Outlook.MailItem Then
Dim oMail As Outlook.MailItem: Set oMail = items
Dim defMail As Outlook.MailItem: Set defMail = defitems
If oMail.SenderEmailAddress = "" & defMail.SenderEmailAddress = "" & defMail.Body = oMail.Body & defMail.UnRead = False Then
oMail.UnRead = True
oMail.Save
End If
End If
Next
Next
On Error GoTo 0
End Sub
"" contains my mail...
It looks like you tried with code from other than VBA.
I broke the If statement into separate parts as it is easier to follow and to debug.
Option Explicit
Sub precitane()
Dim myDestFolder As Folder
Dim mydeffolder As Folder
Dim item As Object
Dim defItem As Object
Set myDestFolder = Session.Folders("mailAddress2").Folders("Inbox").Folders("Test")
Set mydeffolder = Session.GetDefaultFolder(olFolderInbox).Folders("Test3")
For Each item In myDestFolder.items
If TypeOf item Is MailItem Then
For Each defItem In mydeffolder.items
If TypeOf defItem Is MailItem Then
If item.senderEmailAddress = defItem.senderEmailAddress Then
If item.Body = defItem.Body Then
If item.UnRead = False Then
defItem.UnRead = False
'If necessary
'item.Save
Exit For
End If
End If
End If
End If
Set defItem = Nothing
Next
End If
Set item = Nothing
Next
Debug.Print "Done."
End Sub

How to run a macro that requires an argument "myitem As Outlook.mailItem"?

I have this:
Public Sub MoveMails (myitem As Outlook.mailItem)
...
End Sub
Runs automatically from a rule when I receive a new email.
I want launch this when I want. I tried with Call MoveMails but I don't know the argument for myitem As Outlook.mailItem.
I receive several mails. My idea is to move all. I have several conditions: filter by subject, body... and I move them to different folders.
Now that I know you wish to run this on multiple items at once.
Remove the parameter (myitem As Outlook.MailItem) from the sub to run on all items in the folder, or in a selection.
Copied from the code you posted (I've changed the formatting a bit too);
Public Sub Corrected()
'==========================================
'Declare variables:
Dim myNameSpace As Outlook.NameSpace
Dim myInbox As Outlook.Folder
Dim myDestFolder As Outlook.Folder
'Set variables:
Set myNameSpace = Application.GetNamespace("MAPI")
Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
Set myDestFolder = myInbox.Folders("CHECK")
'===========================================
'Declare the variable MyItem but don't set it:
Dim MyItem As Outlook.MailItem
'Create a loop for all items in a certain folder:
For Each MyItem In myInbox 'Or for a subfolder use '...In MyInbox.Folders("FolderName")'
'Or to check selected items you could use the below:
'For Each MyItem in Application.ActiveExplorer.Selection
'if body contains alarm then move
If InStr(MyItem.Body, "alarm") > 0 Then
MyItem.Move myDestFolder
End If
'if subject contains Urgent move
If InStr(MyItem.Subject, "Urgent") > 0 Then
MyItem.Move myDestFolder
End If
'if body contains MASTER then categorize
If InStr(MyItem.Body, "MASTER") > 0 Then
MyItem.Categories = "Boss"
MyItem.Save
End If
Next MyItem 'This loops onto the next item in the selection or folder,
'so it checks them all automatically.
End Sub
I found a sub for selecting the current item here - it has options for whether the item is open in it's own window (inspector) or in the main Outlook window (explorer).
I recommend you add the custom function GetCurrentItem() from that page to your module and use that as your myitem parameter.
So to call the MoveMails sub Call Movemails(GetCurrentItem()).
Function GetCurrentItem() As Object
Dim objApp As Outlook.Application
Set objApp = Application
On Error Resume Next
Select Case TypeName(objApp.ActiveWindow)
Case "Explorer"
Set GetCurrentItem = objApp.ActiveExplorer.Selection.Item(1)
Case "Inspector"
Set GetCurrentItem = objApp.ActiveInspector.CurrentItem
End Select
Set objApp = Nothing
End Function

On Error Resume Next to ignore Error 440 when attempting to create an existing folder

Step 1:
I want to make a folder, and if it fails (it may already exist), I want to ignore and move on.
Sub MakeFolder()
'declare variables
Dim outlookApp As Outlook.Application
Dim NS As Outlook.NameSpace
'set up folder objects
Set outlookApp = New Outlook.Application
Set outlookApp = New Outlook.Application
Set NS = outlookApp.GetNamespace("MAPI")
Set objOwner = NS.CreateRecipient("email#host.com")
objOwner.Resolve
Set outlookInbox = NS.GetSharedDefaultFolder(objOwner, olFolderInbox)
'make a folder, maybe
Dim newFolder
On Error Resume Next
Set newFolder = outlookInbox.Folders.Add("myNewFolder")
On Error GoTo -1
On Error GoTo 0
End Sub
I get an error:
If the folder doesn't exist, it creates it.
Step2:
I have a list of folders (about 60) that may change over time. Because of this, I'd like to run a script checking for new folders and then create them.
For Each fol In folders
On Error Resume Next
Set newFolder = outlookInbox.Folders.Add(fol)
If Err.Number <> 0 Then
On Error GoTo -1
Else:
Debug.Print fol & " created "
End If
On Error GoTo 0
Next ID
Same here, the outlookInbox.Folders.Add() throws errors regardless of the return next, if it can't create that folder.
Now that you fixed your IDE, you could use the following code
Option Explicit
Public Sub Example()
Dim olNs As Outlook.NameSpace
Set olNs = Application.GetNamespace("MAPI")
Dim Inbox As Outlook.Folder
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Dim SubFolder As Outlook.Folder
'// SubFolder Name
Dim FolderName As String
FolderName = "myNewFolder"
'// Check if folder exist else create one
If FolderExists(Inbox, FolderName) = True Then
Debug.Print "Folder Exists"
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
End Sub
'// Function - Check folder Exist
Private Function FolderExists(Inbox As Folder, FolderName As String)
Dim Sub_Folder As MAPIFolder
On Error GoTo Exit_Err
Set Sub_Folder = Inbox.Folders(FolderName)
FolderExists = True
Exit Function
Exit_Err:
FolderExists = False
End Function

Mark as Read loop errors on some mail items inconsistently

I receive 4000+ emails over a weekend and all throughout the week that are filtered into folders via rules. I created a macro to mark all these folders as read. However, on some mail items it errors with runtime error 91 object variable or with block variable not set.
If I skip the errors with On Error Resume Next it loops through everything but just doesn't set a bunch of the mail items as read. I can then rerurn the macro to get most of the remaining ones. If I run the macro 3-4 times it will eventually get them all.
How can I improve this macro to consistently mark ALL the items as read?
Public Function GetInboxFolderID(FolderName As String) As String
Dim nsp As Outlook.Folder
Dim mpfSubFolder As Outlook.Folder
Dim mpfSubFolder2 As Outlook.Folder
Dim flds As Outlook.Folders
Dim flds2 As Outlook.Folders
Set nsp = Application.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox)
Set flds = nsp.Folders
Set mpfSubFolder = flds.GetFirst
Do While Not mpfSubFolder Is Nothing
If mpfSubFolder.Name = FolderName Then
GetInboxFolderID = mpfSubFolder.EntryID
Exit Function
End If
Set flds2 = mpfSubFolder.Folders
Set mpfSubFolder2 = flds2.GetFirst
Do While Not mpfSubFolder2 Is Nothing
If mpfSubFolder2.Name = FolderName Then
GetInboxFolderID = mpfSubFolder2.EntryID
Exit Function
End If
Set mpfSubFolder2 = flds2.GetNext
Loop
Set mpfSubFolder = flds.GetNext
Loop
End Function
Private Sub processFolder(ByVal oParent As Outlook.MAPIFolder)
Dim oFolder As Outlook.MAPIFolder
Dim oMail As Outlook.MailItem
Dim oFiltered As Outlook.Items
Set oFiltered = oParent.Items.Restrict("[unread] = true")
On Error Resume Next
For Each oMail In oFiltered
oMail.UnRead = False
Next
If (oParent.Folders.Count > 0) Then
For Each oFolder In oParent.Folders
processFolder oFolder
Next
End If
End Sub
Public Sub markNocAsRead()
Dim SubFolder As MAPIFolder
Set SubFolder = Session.GetDefaultFolder(olFolderCalendar).Parent.Folders("NOC Alerts")
'Application.Session.GetFolderFromID (GetInboxFolderID("NOC Alerts"))
Call processFolder(SubFolder)
End Sub
I was able to get this working consistently by taking the advice of Ryan Wildry in a comment above.
I replaced my loop:
Set oFiltered = oParent.Items.Restrict("[unread] = true")
On Error Resume Next
For Each oMail In oFiltered
oMail.UnRead = False
Next
with a loop that iterates from the end to beginning:
Set oFiltered = oParent.Items.Restrict("[unread] = true")
For I = oFiltered.Count To 1 Step -1
Set oMail = oFiltered(I)
oMail.UnRead = False
Next

Run-time error 13 randomly while iterating emails in a public folder

I receive a random run-time error 13 (type mismatch). This routine works most of the time. The folder passed as an argument is legitimate at the time of the failure.
From what I can see in the debugger, objitem is missing some of the fields during runtime. After it break-points in the debugger, I can immediately single-step (re-executing the offending line) and there is no error.
I attempted using on error goto to sleep then retry various lines, and the error persists until it stops in the debugger.
I also attempted changing between the For ii and For Each forms of the loop commands.
I also temporarily disabled by anti-virus.
I iterate over a large number of public folders. My Outlook client is 2003 running under XP, and I am attached to Exchange Server version 7654.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim objitem As MailItem
Dim ii As Integer
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
For ii = 1 To objFolder.Items.Count
If objFolder.Items(ii).Class = olMail Then
If TypeName(objFolder.Items(ii)) <> "MailItem" Then
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(objFolder.Items(ii)))
GoTo NextdblLoop
End If
Set objitem = objFolder.Items(ii)
CheckEmailForErrorReports (objFolder.Items(ii))
End If
NextdblLoop:
Next ii
End Sub
Code below is modified per #dmitry suggestions and now works.
Sub SearchFolders(objFolder As Outlook.MAPIFolder)
Dim objFolders As Outlook.Folders
Dim subFolder As Outlook.MAPIFolder
Dim Objitem As Outlook.MailItem
Dim ii As Integer
Dim ThisItem As Object
Dim Items As Outlook.Items
' Recurse through all subfolders
Set objFolders = objFolder.Folders
For Each subFolder In objFolders
Call SearchFolders(subFolder)
Next subFolder
' Search the emails
Set Items = objFolder.Items
For ii = 1 To Items.Count
Set ThisItem = Items.item(ii)
If ThisItem.Class = olMail Then
If VarType(ThisItem) = 9 Then GoTo NextdblLoop
Set Objitem = ThisItem
CheckEmailForErrorReports (objFolder.Items(ii))
Set Objitem = Nothing
End If
Set ThisItem = Nothing
NextdblLoop:
Next ii
Set Items = Nothing
End Sub
Firstly, do not use multiple dot notation; cache the Items collection before entering the loop.
Secondly, release the variables as soon as you are done with them
dim item As Object
dim Items as Outlook.Items
set Items = objFolder.Items
For ii = 1 To Items.Count
set item = Items.Item(ii)
If item.Class = olMail Then
If TypeName(item) <> "MailItem" Then
'THIS CAN NEVER HAPPEN. The check above is sufficient
MsgBox ("Type mismatch: object s/b MailItem and is " & TypeName(item))
GoTo NextdblLoop
End If
Set objitem = item
CheckEmailForErrorReports (objitem)
Set objitem = Nothing
End If
Set item = Nothing
NextdblLoop:
Next ii
End Sub