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

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

Related

Folder path to enterprise vault using VBA for email migration

I have a long list of folders and to many rules for outlook to handle using the standard rules manager. I wrote code that would classify and move items to folders but recently I was migrated to an Enterprise Vault. I am trying to find the folder path to update my code. I tried something like
Outlook.Application.GetNamespace("MAPI").Folders("Vault - DOE, JOHN").Folders("My Migrated PSTs").Folders("PR2018")
but honestly I have no idea what the correct path should be. Everything I find online deals with pulling selected items out of the vault and not moving items into it. Below is an excerpt of the existing code. This is on Office 365/Outlook 2016.
Sub Sort_Test(Item)
Dim Msg As Object
Dim Appt As Object
Dim Meet As Object
Dim olApp As Object
Dim objNS As Object
Dim targetFolder As Object
On Error GoTo ErrorHandler
Set Msg = Item
Set PST = Outlook.Application.GetNamespace("MAPI").Folders("PR2018")
checksub = Msg.Subject
checksend = Msg.Sender
checksendname = Msg.SenderName
checksendemail = Msg.SenderEmailAddress
checkbod = Msg.Body
checkto = Msg.To
checkbcc = Msg.BCC
checkcc = Msg.CC
checkcreation = Msg.CreationTime
checksize = Msg.Size
'Classes Folder
If checksub Like "*Files*Lindsey*" Or checksub Like "*Course Login*" _
Or checksend Like "*Award*eBooks*" Then
Set targetFolder = PST.Folders("Education").Folders("Classes")
Msg.Move targetFolder
GoTo ProgramExit
End If
If targetFolder Is Nothing Then
GoTo ProgramExit
' Else
' Msg.Move targetFolder
End If
' Set olApp = Nothing
' Set objNS = Nothing
Set targetFolder = Nothing
Set checksub = Nothing
Set checksend = Nothing
ProgramExit:
Exit Sub
ErrorHandler:
MsgBox Err.Number & " - " & Err.Description
Resume ProgramExit
End Sub
Try this code:
Sub MoveToFolder()
Dim olApp As New Outlook.Application
Dim olNameSpace As Outlook.NameSpace
Dim olArcFolder As Outlook.MAPIFolder
Dim olCompFolder As Outlook.MAPIFolder
Dim mailboxNameString As String
Dim myInspectors As Outlook.MailItem
Dim myCopiedInspectors As Outlook.MailItem
Dim myItem As Outlook.MailItem
Dim M As Integer
Dim iCount As Integer
Set olNameSpace = olApp.GetNamespace("MAPI")
Set olArcFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Archived")
Set olCompFolder = olNameSpace.Folders("Emails Stored on Computer").Folders("Computer")
For M = 1 To olArcFolder.items.Count
Set myItem = olArcFolder.items(M)
myItem.Display
Set myInspectors = Outlook.Application.ActiveInspector.CurrentItem
Set myCopiedInspectors = myInspectors.copy
myCopiedInspectors.Move olCompFolder
myInspectors.Close olDiscard
Next M
Here is a link for you reference:
Do for all open emails and move to a folder

Reference to non-default non-English inbox

I am trying set a reference to a non-default inbox in MS Outlook. I have found a code in SO,
Dim objNS As Outlook.NameSpace
Dim objFolder As Outlook.MAPIFolder
Set objNS = GetNamespace("MAPI")
Set objFolder = objNS.Folders("Procurement, Request")
Set objFolder = objFolder.Folders("Inbox")
which is OK when inbox is named "Inbox".
There is a possibility for inboxes to be named in non-English languages.
You may refer to the default inbox by
objNS.getdefaultfolder(6)
But what about non-defaults?
You should be able to get inboxes by Store index or name.
Option Explicit
Sub Inbox_by_Store()
Dim allStores As Stores
Dim storeInbox As Folder
Dim i As Long
Set allStores = Session.Stores
For i = 1 To allStores.count
Debug.Print i & " DisplayName - " & allStores(i).DisplayName
Set storeInbox = Nothing
On Error Resume Next
Set storeInbox = allStores(i).GetDefaultFolder(olFolderInbox)
On Error GoTo 0
If Not storeInbox Is Nothing Then
storeInbox.Display
End If
Next
ExitRoutine:
Set allStores = Nothing
Set storeInbox = Nothing
End Sub

How to move messages from a specific account?

I have multiple accounts attached to Outlook 2010.
I want to move messages from a specific account, older than X days, to a .pst file for local storage.
I found scripts to move messages from the default inbox, but nothing on specifying an account.
I know you can specify an account when sending email using
Set OutMail.SendUsingAccount = Outlook.Application.Session.Accounts.Item(2)
but I can't find anything for looking into another account.
I've found the stores references for the folders (\Inbox and \Sent) and I know how to specify the days old. I have a script that works, but only in my primary account.
After some more searching and testing I came up with the following solution. This was actually from a 2009 post on stackoverflow here: Original VBA
It uses a public function to build the folder locations and a Subroutine to look for received dates older than 60 days and move those files to the specified locations.
The public function is:
Public Function GetFolder(strFolderPath As String) As MAPIFolder
Dim objNS As NameSpace
Dim colFolders As folders
Dim objFolder As MAPIFolder
Dim arrFolders() As String
Dim i As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objNS = GetNamespace("MAPI")
On Error Resume Next
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
End If
Next
End If
On Error GoTo TrapError
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Exit_Proc:
Exit Function
TrapError:
MsgBox Err.Number & " " & Err.Description
End Function
The subroutine that does the actual work is below.
I added the Pass as Integer to allow the routine to work through two different source and destination folders. If I change the Sub name to Application_Startup it will run whenever outlook is started.
PST Folder Name\Archive-Inbox - PST folder name in Outlook with sub-folder
Email Account Name\Inbox - Account name in Outlook with sub-folder
Sub MoveOldEmail()
Dim oItem As MailItem
Dim objMoveFolder As MAPIFolder
Dim objInboxFolder As MAPIFolder
Dim i As Integer
Dim Pass As Integer
For Pass = 1 To 2
If Pass = 1 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Inbox")
Set objInboxFolder = GetFolder("Email Account Name\Inbox")
ElseIf Pass = 2 Then
Set objMoveFolder = GetFolder("PST Folder Name\Archive-Sent Items")
Set objInboxFolder = GetFolder("Email Account Name\Sent Items")
End If
For i = objInboxFolder.Items.Count - 1 To 0 Step -1
With objInboxFolder.Items(i)
''Error 438 is returned when .receivedtime is not supported
On Error Resume Next
If .ReceivedTime < DateAdd("d", -60, Now) Then
If Err.Number = 0 Then
.Move objMoveFolder
Else
Err.Clear
End If
End If
End With
Next
Next Pass
Set objMoveFolder = Nothing
Set objInboxFolder = Nothing
End Sub
Hope this helps someone else.

Move selected items to folder

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

Accessing another maibox in outlook using vba

I have two mailboxes in my Outlook.
One that is mine and it automatically logs me in when I log in to my pc and another I have that is for mail bounces.
I really need to access the inbox of the mail's account but I just can't seem to do it.
And there is no way I can make the mailbox of the mail account to be my default mailbox
Here is the code I have so far:
Public Sub GetMails()
Dim ns As NameSpace
Dim myRecipient As Outlook.Recipient
Dim aFolder As Outlook.Folders
Set ns = GetNamespace("MAPI")
Set myRecipient = ns.CreateRecipient("mail#mail.pt")
myRecipient.Resolve
If myRecipient.Resolved Then
MsgBox ("Resolved")
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
Else
MsgBox ("Failed")
End If
End Sub
The problem I am getting is at the
Set aFolder = ns.GetSharedDefaultFolder(myRecipient, olFolderInbox)
I get the Resolved msgbox so I know that is working but after that I get an error:
Run-Time Error
which doesn't say much about the error itself.
Can anyone help me out here please?
Thanks
If the folder you wish to access is not an Exchange folder, you will need to find it, if it is an Exchange folder, try logging on to the namespace.
Log on to NameSpace
Set oNS = oApp.GetNamespace("MAPI")
oNS.Logon
Find Folder
As far as I recall, this code is from Sue Mosher.
Public Function GetFolder(strFolderPath As String) As Object 'MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder" ''
Dim apOL As Object 'Outlook.Application '
Dim objNS As Object 'Outlook.NameSpace '
Dim colFolders As Object 'Outlook.Folders '
Dim objFolder As Object 'Outlook.MAPIFolder '
Dim arrFolders() As String
Dim I As Long
On Error GoTo TrapError
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set apOL = CreateObject("Outlook.Application")
Set objNS = apOL.GetNamespace("MAPI")
On Error Resume Next
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
End If
Next
End If
Set GetFolder = objFolder
Set colFolders = Nothing
Set objNS = Nothing
Set apOL = Nothing
End Function