In MS Outlook (2016) I am working on a VBA procedure to more quickly archive certain, individually selected e-mails into certain folders in my e-mail archive.
I have a procedure that does the trick when I address the target folder manually:
'[...]
Dim MoveToFolder As Outlook.MAPIFolder
'[...]
Set MoveToFolder = ns.Folders("Archive").Folders("Projekte-Archiv").Folders("P03_NetRef")
'[...]
With this the procedure knows what folder to move pre-selected e-mail to.
Now my problem:
I am trying to set the "MoveToFolder" folder object through a string variable giving it all the necessary data.
Why do I want to do this: Handing over the folder data as a string variable would allow me to use the same procedure for as many folders in as many hierarchy levels I want.
Here is what I came up with, using the CType function:
'[...]
Dim MoveToFolder As Outlook.MAPIFolder
'[...]
Set MoveToFolder = CType("ns.Folders(""Archive"").Folders(""Projekte-Archiv"").Folders(""P03_NetRef"")", Outlook.MAPIFolder)
'[...]
(The idea is of course in a next step to insert the string through a variable, not in plain writing like the example.)
This does not work. The object type 'Outlook.MAPIFolder' results in an error on compiling ("method or data object not found").
Later insight
As I understood later on, the CType() function is not available in VBA (as opposed to VB.net).
Untested:
Set MoveToFolder = GetFolder(ns, "Archive|Projekte-Archiv|P03_NetRef")
A function to parse the path:
Function GetFolder(root, fpath)
Dim f As Object
Dim arr, i
arr = Split(fpath, "|")
For i = 0 To UBound(arr)
If i = 0 Then
Set f = root.Folders(arr(i))
Else
Set f = f.Folders(arr(i))
End If
Next i
Set GetFolder = f
End Function
Related
Is there a method in VBA to achieve the same effect of right-clicking on a folder in the folder pane and selecting 'Sort Subfolders A to Z'?
As a comparison, the code below from Microsoft.com sorts Items in a folder; however, it does not appear that the .Sort method used in this code is available for the Folders object like it is for the Items object.
Sub SortByDueDate()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myItem As Outlook.TaskItem
Dim myItems As Outlook.Items
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderTasks)
Set myItems = myFolder.Items
myItems.Sort "[DueDate]", False
For Each myItem In myItems
MsgBox myItem.Subject & "-- " & myItem.DueDate
Next myItem
End Sub
Additionally, it does not appear that there are any methods available for moving folders in the tree.
Is more extensive code required to replicate the native 'Sort Subfolders A to Z' action with VBA?
Can this be achieved with PropertyAssessor and, if so, what is the proper syntax for setting the PR_SORT_POSITION property? For example, the code below results in an error, as commented in the code.
Sub Example()
Dim myProp As String
Dim myValue As Variant
Dim oFolder As Folder
Set oFolder = Application.Session.GetDefaultFolder(olFolderInbox)
myProp = "http://schemas.microsoft.com/mapi/proptag/0x30200102"
myValue = "FD7F"
oFolder.PropertyAssessor.SetProperty myProp, myValue 'Run-time error '438': Object doesn't support this property or method
End Sub
The Outlook object model doesn't provide any property or method to sort folders. You may find the NavigationPane object helpful. See Customizing the Navigation Pane for more information.
You can sort the folders in the Outlook UI by explicitly setting the PR_SORT_POSITION property on each subfolder - see Get folder list ordered as displayed
I posted my code here because this was high in Google results and all other threads were closed
https://answers.microsoft.com/en-us/outlook_com/forum/all/sorting-outlook-subfolders-z-a/9aef727c-510c-49e0-869d-4234373b71d7
https://answers.microsoft.com/en-us/outlook_com/forum/all/sort-order-of-subfolders/a3b55181-4f5a-43c1-82b3-94eb68a8407b
I've made custom VBA code to sort subfolders Z-A - it will load the folder order [unfortunately you still need to order it A-Z within outlook] and then reverse it so it is Z-A
I needed to quickly adjust a tonne of folders and couldn't find any code anywhere, so I quickly made the below to help patch the issue.
I didn't have the time to write lots of detail about how it works.
Known issues with the code:
It doesn't always sort the first folder. No idea why.
It doesn't seem to like it when you're looking at the list of subfolders - minimise it then run the code
This code is used to reverse the sorting of subfolders under Inbox, you'll need to adjust as required.
Sub sortZA()
Dim email_name: email_name = "email#emails.com" 'write the name of the mailbox as it appears in outlook
Dim objMainFolder As Outlook.Folder
Dim Folders As Outlook.Folders
Dim Folderx As Outlook.Folder
Dim sort_order, sort_order_b, arr
Set arr = CreateObject("System.Collections.ArrayList")
Set arr_sorted = CreateObject("System.Collections.ArrayList")
dim found_folder: found_folder=0
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
If LCase(Folderx.Name) = LCase(email_name) Then
Set objMainFolder = Folderx.Folders("Inbox") 'adjust as required. Add more folders via .folders("name")
found_folder=1
End If
Next
if found_folder =0 then
msgbox "the email folder with the name '" & email_name & "' was not found"
exit sub
end if
Dim reloadFolder As Outlook.Folder
Dim propertyAccessor As Outlook.propertyAccessor
For Each Folderx In objMainFolder.Folders
' if there is an error, then there might not be any order data. Try reordering them manually. Also make sure loading the email as the main profile instead of as an additional mailbox.
'On Error Resume Next
Set propertyAccessor = Folderx.propertyAccessor
sort_order = propertyAccessor.BinaryToString(propertyAccessor.GetProperty("http://schemas.microsoft.com/mapi/proptag/0x30200102"))
arr.Add Folderx.Name & "##~~##" & sort_order
arr_sorted.Add Folderx.Name & "##~~##" & sort_order
Next
arr.Sort 'keep A-Z (the original list from outlook isn't in A-Z order)
arr_sorted.Sort 'make A-Z
arr_sorted.Reverse 'make Z-A
Dim t, a, b, i, t2, a2, b2
i = 0
For Each arr_folder In arr
t = Split(arr_folder, "##~~##")
a = t(0) 'which folder name?
b = t(1) 'what is the original order? [should already be A-Z]
Set Folders = Application.ActiveExplorer.Session.Folders
For Each Folderx In Folders
'On Error Resume Next
If LCase(Folderx.Name) = LCase(email_name) Then
Set reloadFolder = Folderx.Folders("Inbox").Folders(a)
End If
Next
t2 = Split(arr_sorted(i), "##~~##")
a2 = t2(0) 'which folder name?
b2 = t2(1) 'what is the reversed order?
Set propertyAccessor = reloadFolder.propertyAccessor
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(b2)
i = i + 1
Next
End Sub
Additional Notes: I did try experimenting with applying ordering data manually. I couldn't get it to work properly. All the binary converting code wasn't producing the correct values, and I ended up using HEX(). Here is an example of what I was doing:
Dim custom_order As Long
custom_order = 15
For Each arr_folder In arr
'the array only contains a list of folder names.. we need to load the folder in outlook to process it again. The below line of code loads the main email inbox, then the subfolder from the array [different from the above code]
Set reloadFolder = Application.Session.GetDefaultFolder(olFolderInbox).Folders(arr_folder)
Set propertyAccessor = reloadFolder.propertyAccessor
hexval = Hex(custom_order)
propertyAccessor.SetProperty "http://schemas.microsoft.com/mapi/proptag/0x30200102", propertyAccessor.StringToBinary(hexval)
custom_order = custom_order + 1
Next
End Sub
I just started using VBA and I am trying to launch the rules that I have thought python so I gave a try with the usual rule to short mails form someone and move that emails from inbox to another folder (in this case named zzz). Since I have three different accounts on outlook I want to do it for the account named myemail#company.com in the code.
Sub ResolveName()
Dim ns As NameSpace
Set ns = Application.Session
Dim acc As Account
Dim f As Folder
Dim myDestFolder As Folder
Dim myItem As Object
For Each acc In ns.Accounts
If acc = "myemail#company.com" Then
Set f = acc.DeliveryStore.GetDefaultFolder(olFolderInbox)
Set myDestFolder = f.Folders("zzz")
Set myItem = f.Items.Find("[SenderName] = 'SendersName Surname'")
While TypeName(myItem) <> "Nothing"
myItem.Move myDestFolder
Set myItem = myItems.FindNext
Wend
End If
Next
End Sub
When I run it, I get the following error
The following error has happened '-2147221233 (8004010f)' on execution time
No object found.
I have no idea what I am doing wrong
Thank you in advance.
Which line of code gives an error? Did you try to run the code under the debugger line-by-line?
Anyway, the following line of code is not correct:
If acc = "myemail#company.com" Then
The account object is not a string to compare. You need to use the Account.SmtpAddress property which returns a string representing the Simple Mail Transfer Protocol (SMTP) address for the Account.
However, I've found a similar issue which explains possible causes - the error number can tell us about a problem with a PST file (storage).
Im trying to check if a folder exists; if it does not then create it. The below is just throwing a run-time error.
Sub AddClose()
Dim myNameSpace As Outlook.NameSpace
Dim myFolder As Outlook.Folder
Dim myNewFolder As Outlook.Folder
Set myNameSpace = Application.GetNamespace("MAPI")
Set myFolder = myNameSpace.GetDefaultFolder(olFolderInbox)
If myFolder.Folders("Close") = 0 Then
myFolder.Folders.Add("Close").Folders.Add ("EID1")
myFolder.Folders("Close").Folders.Add ("EID2")
myFolder.Folders("Close").Folders.Add ("EID3")
End If
End Sub
However, If the folder exists then the below works...
If myFolder.Folders("Close") > 0 Then
MsgBox "Yay!"
End If
Why? What can I do to correct the problem?
Firstly, you are comparing the result of the myFolder.Folders("Close") call (which is supposed to return a MAPIFolder object) with an integer (0). You need to use Is Nothing or Is Not Nothing operator.
Secondly, MAPIFolder.Folders.Item() raises an exception if the folder with a given name is not found. You need to trap that exception (as ugly as it is in VBA) and either check the Err.Number value or check that the return object is set:
On Error Resume Next
set subFolder = myFolder.Folders.Item("Close")
if subFolder Is Nothing Then
set subFolder = myFolder.Folders.Add("Close")
End If
I do not understand: If myFolder.Folders("Close") = 0 Then. myFolder.Folders("Close") is a folder and I would not have thought of comparing it against zero. Do you have a reference to a site where this functionality is explained because I would like to understand it?
I wish to create a folder if it does not exist often enough to have written a function. My function does not have ideal parameters for your requirement but it works. I offer it as tested code that does what you want or as a source of ideas for your own code.
Sub DemoGetCreateFldr shows how to use the function GetCreateFldr to achieve the effect I believe you seek.
I do not use GetDefaultFolder because, on my system, it returns a reference to a store I do not use. “Outlook Data File” is Outlook’s default store but the wizard created a separate store for each of my two email addresses. In Set Store = Session.Folders("Outlook Data File"), replace "Outlook Data File" with the name of the store holding the Inbox for which you want to create subfolders.
The first call of GetCreateFldr creates folder “Close” if it does not exist and then creates folder “EID1”. I save the reference to the folder, and use Debug.Print to demonstrate it returns the correct reference.
For folders “EID2” and “EID3”, I do not save the reference which matches your code.
If folders “Close”, “EID1”, “EID2” and “EID3” exist, GetCreateFldr does not attempt to create them although it still returns a reference.
Hope this helps.
Sub DemoGetCreateFldr()
Dim FldrEID1 As Folder
Dim FldrNameFull(1 To 3) As String
Dim Store As Folder
Set Store = Session.Folders("Outlook Data File")
FldrNameFull(1) = "Inbox"
FldrNameFull(2) = "Close"
FldrNameFull(3) = "EID1"
Set FldrEID1 = GetCreateFldr(Store, FldrNameFull)
Debug.Print FldrEID1.Parent.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Parent.Name & "|" & _
FldrEID1.Parent.Name & "|" & _
FldrEID1.Name
FldrNameFull(3) = "EID2"
Call GetCreateFldr(Store, FldrNameFull)
FldrNameFull(3) = "EID3"
Call GetCreateFldr(Store, FldrNameFull)
End Sub
Public Function GetCreateFldr(ByRef Store As Folder, _
ByRef FldrNameFull() As String) As Folder
' * Store identifies the store, which must exist, in which the folder is
' wanted.
' * FldrNameFull identifies a folder which is or is wanted within Store.
' Find the folder if it exists otherwise create it. Either way, return
' a reference to it.
' * If LB is the lower bound of FldrNameFull:
' * FldrNameFull(LB) is the name of a folder that is wanted within Store.
' * FldrNameFull(LB+1) is the name of a folder that is wanted within
' FldrNameFull(LB).
' * FldrNameFull(LB+2) is the name of a folder that is wanted within
' FldrNameFull(LB+1).
' * And so on until the full name of the wanted folder is specified.
' 17Oct16 Date coded not recorded but must be before this date
Dim FldrChld As Folder
Dim FldrCrnt As Folder
Dim ChildExists As Boolean
Dim InxC As Long
Dim InxFN As Long
Set FldrCrnt = Store
For InxFN = LBound(FldrNameFull) To UBound(FldrNameFull)
ChildExists = True
' Is FldrNameFull(InxFN) a child of FldrCrnt?
On Error Resume Next
Set FldrChld = Nothing ' Ensure value is Nothing if following statement fails
Set FldrChld = FldrCrnt.Folders(FldrNameFull(InxFN))
On Error GoTo 0
If FldrChld Is Nothing Then
' Child does not exist
ChildExists = False
Exit For
End If
Set FldrCrnt = FldrChld
Next
If ChildExists Then
' Folder already exists
Else
' Folder does not exist. Create it and any children
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
For InxFN = InxFN + 1 To UBound(FldrNameFull)
Set FldrCrnt = FldrCrnt.Folders.Add(FldrNameFull(InxFN))
Next
End If
Set GetCreateFldr = FldrCrnt
End Function
Its not a good coding practice to user on error.
I would recommend you to traverse through the folders.
Then if a certain name is not found create it.
The code below part of my macro I use.
It looks for a "Duplicates" under inbox.
It intentionally doesn't do this recursively.
Sub createDuplicatesFolder()
Dim folderObj, rootfolderObj, newfolderObj As Outlook.folder
Dim NameSpaceObj As Outlook.NameSpace
duplicatefolder = False
For Each folderObj In Application.Session.Folders
If folderObj.Name = "Duplicates" Then duplicatefolder = True
Next
If duplicatefolder = False Then
Set rootfolderObj = NameSpaceObj.GetDefaultFolder(olFolderInbox)
Set newfolderObj = rootfolderObj.Folders.Add("Duplicates")
End Sub
A slow way. Depends on number of folders.
Sub checkFolder()
Dim folderObj As folder
Dim rootfolderObj As folder
Dim newfolderObj As folder
Dim checkFolderName As String
' Check and add in the same location
Set rootfolderObj = Session.GetDefaultFolder(olFolderInbox)
' Check and add the same folder name
checkFolderName = "checkedFolder"
For Each folderObj In rootfolderObj.folders
If folderObj.name = checkFolderName Then
Set newfolderObj = rootfolderObj.folders(checkFolderName)
'Reduces the search time, if the folder exists
Exit For
End If
Next
If newfolderObj Is Nothing Then
Set newfolderObj = rootfolderObj.folders.add(checkFolderName)
End If
Debug.Print newfolderObj.name
End Sub
A fast way. Add without checking existing folders.
Sub addFolder_OnErrorResumeNext()
Dim rootFolder As folder
Dim addFolder As folder
Dim addFolderName As String
Set rootFolder = Session.GetDefaultFolder(olFolderInbox)
addFolderName = "addFolder"
On Error Resume Next
' Bypass expected error if folder exists
Set addFolder = rootFolder.folders.add(addFolderName)
' Return to normal error handling for unexpected errors
' Consider mandatory after On Error Resume Next
On Error GoTo 0
' In other cases the expected error should be handled.
' For this case it can be ignored.
Set addFolder = rootFolder.folders(addFolderName)
Debug.Print addFolder.name
End Sub
When using the Move method on an AppointmentItem in an Outlook macro, I lose the ability to receive updates because it is creating a copy of the item instead of truly moving it. This behavior causes the item to no longer be linked with the original and will not retain item updates as a result.
I want to replicate through VBA the cut/paste behavior you get which is able to maintain the original object and does not cause updates to be lost.
I believe this has something to do with the GlobalAppointmentID based on searching around, however I have not been able to find a way to actually move the appointment.
The code I'm using is below. GetFolderFromPath is a helper function to just return a folder object from the path, which works perfectly well.
Sub MoveItem()
Dim targetPath As String: targetPath = "\\tnolan#microsoft.com\Calendar\OOFS"
If Application.ActiveExplorer.Selection.Count = 0 Then
MsgBox ("No item selected")
Exit Sub
Else
Dim targetFolder As Outlook.Folder
Set targetFolder = GetFolderFromPath(targetPath)
For x = 1 To Application.ActiveExplorer.Selection.Count
Dim oSelected As Variant
Set oSelected = Application.ActiveExplorer.Selection.Item(x)
If oSelected.Class = olAppointment Then
Dim NS As NameSpace: Set NS = Application.GetNamespace("MAPI")
Dim oAppt As AppointmentItem: Set oAppt = NS.GetItemFromID(oSelected.EntryID)
oAppt.Move targetFolder
Set oAppt = Nothing
Set NS = Nothing
End If
Set oSelected = Nothing
Next x
Set targetFolder = Nothing
End If
End Sub
Outlook processes incoming meeting updates/deletions only against the default Calendar folder. If you move an appointment to a different folder, meeting update in your Inbox will create a new appointment in the default Calendar folder.
After playing around with my code for a little bit, I've found that this code works for me in a similar situation:
oAppt.CopyTo(targetFolder, olCopyAsAccept)
oAppt.Delete
I have a feeling that for some reason the AppointmentItem.Move command passes as olCreateAppointment which would always create a new GlobalAppointmentID.
However, this still has a side-effect of responding accept to the Appointment.
I'm trying to create a custom rule for Outlook 2010 that inspect the subject of the email and if it makes a regular expression it's moved into a specific folder.
However when I run the script I get the following error when I try and get an Outlook.Folder object for the folder I want to move the message to:
Run-time error '91':
Object variable or With block variable not set
Below is the VBA script that I am using to check the email subject and move the message to the specified folder if it matches.
Sub MoveToETS(Item As Outlook.MailItem)
Dim Subject As String
Subject = Item.Subject
Dim FolderToMoveTo As Outlook.Folder
Set FolderToMoveTo = GetFolder("ETS")
If (CheckSubject(Subject, "^[Project|Bug] (\d+?) - \[[UPDATE|NEW|RESOLVED]\]")) Then
Item.Move (FolderToMoveTo)
End If
End Sub
Function CheckSubject(Subject As String, PatternToCheck As String)
Dim ObjRegExp As RegExp
Dim ObjMatch As Match
Set ObjRegExp = New RegExp
ObjRegExp.Pattern = PatternToCheck
If (ObjRegExp.Text(Subject) = True) Then
CheckSubject = True
End If
End Function
Function GetFolder(ByVal FolderName As String) As Outlook.Folder
Dim ObjFolder As Outlook.Folder
Set ObjFolder = Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders("ETS")
GetFolder = ObjFolder
End Function
Your last but one line needs to be
Set GetFolder = ObjFolder
In your GetFolder function, you also hard-coded the folder name.
Line reads:
Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders("ETS")
Should read:
Outlook.Application.Session.GetDefaultFolder(olFolderInbox).Folders(FolderName)