Define folder location - vba

Working on a macro for Outlook 2007 which selects messages in a folder.
In example 1 and 2 below the customers folder is selected, then a specific customer folder is selected. The method to define the location seems clumsy. Is there a cleaner way to do this?
Right clicking on the sub-folder and selecting properties, the path shown is: "\mailbox-name\customers\customer-xyz". Referencing the path this way in a macro doesn't work. Is it possible to reference the folder location in a more direct manner?
Set olNamespace = olApp.GetNamespace("MAPI")
' Example-1, Select folder by name from default PST inbox
Set FolderKeep = _
olNamespace.GetDefaultFolder(olFolderInbox).Folders("customers").Folders("customer-XYZ")
' Example-2, Select folder by mailbox name/folder/subfolder
Set FolderKeep = _
olNamespace.Folders("mailbox-name").Folders("customers").Folders("customer-XYZ")

A method of pulling the folder out of a path is described here.
http://www.outlookcode.com/d/code/getfolder.htm
Private Function GetFolder(strFolderpath As String) As Folder
' The path argument needs to be in quotation marks and
' exactly match the folder hierarchy that the user sees in the Folder List.
'
' NOTE: If any folder name in the path string contains a "\" character,
' this routine will not work,
'
' As the developer do not use this. It hides errors.
'On Error GoTo GetFolder_Error
Dim objNS As Namespace
Dim objFolder As Folder
Dim arrFolders() As String
Dim colFolders As Folders
Dim i As Long
Dim uErrorMsg As String
' Remove leading slashes, if any
Do While Left(strFolderpath, 1) = "\"
'Debug.Print strFolderpath
strFolderpath = Right(strFolderpath, Len(strFolderpath) - 1)
Loop
Debug.Print strFolderpath
arrFolders() = Split(strFolderpath, "\")
Set objNS = GetNamespace("MAPI")
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
Next
End If
Set GetFolder = objFolder
ExitRoutine:
Set colFolders = Nothing
Set objNS = Nothing
Set objFolder = Nothing
Exit Function
GetFolder_Error:
uErrorMsg = "Err.Number: " & Err.Number & vbCr & "Err.Description: " & Err.Description
MsgBox uErrorMsg
Set GetFolder = Nothing
Resume ExitRoutine
End Function
Private Sub GetFolder_Test()
Dim testFolder As Folder
Set testFolder = GetFolder("\mailbox-name\customers\customer-xyz")
If Not (testFolder Is Nothing) Then testFolder.Display
End Sub

Related

Add a public Folder to my Favorite Folder

I am looking for a VBA Script to automatically add a public folder to the "Favorites" folder in Outlook 365 (to add it as a GPO later). I have found multiple scripts such as this one:
' path to public folder; should be similar to
' "Public Folders\All Public Folders\Company\Sales"
strFolder = "\\Public Folders - gabriel.buehler#wingd.com\All Public Folders\Local Winterthur Holidays"
Call AddFolderToFavorites(strFolder, True)
Sub AddFolderToFavorites(strPath, AddToAddressBook)
Const olContactItem = 2
Set myFolder = GetFolder(strPath)
If Not myFolder Is Nothing Then
myFolder.AddToPFFavorites
' if contacts folder,
' optionally add new Favorite to OAB
If myFolder.DefaultItemType = olContactItem Then
If AddToAddressBook = True Then
strFavFolder = _
"Public Folders\Favorites\" & _
myFolder.Name
Set myFavFolder = GetFolder(strFavFolder)
If Not myFavFolder Is Nothing Then
myFavFolder.ShowAsOutlookAB = True
End If
End If
End If
End If
Set myFolder = Nothing
End Sub
Public Function GetFolder(strFolderPath)
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders = Split(strFolderPath, "\")
Set objApp = CreateObject("Outlook.Application")
Set objNS = objApp.GetNamespace("MAPI")
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 objApp = Nothing
End Function
To be honest: I have not used VBA before, so I don't know if the code itself is correct...but When I start to run the script, it always pops up a window where I should ad a "Macro Name":
When I enter In a macro name and press "run" it says "Compile Error Invalid Outside Procedure".
Can you tell me what I am doing wrong here?
You can manage the Outlook favorites group by accessing the NavigationPane module.
Dim mailModule as Outlook.MailModule
Set mailModule = Application.ActiveExplorer().NavigationPane.Modules.GetNavigationModule(Outlook.OlNavigationModuleType.olModuleMail)
Dim favGroup as Outlook.NavigationGroup
Set favGroup = ailModule.NavigationGroups.GetDefaultNavigationGroup(Outlook.OlGroupType.olFavoriteFoldersGroup)
favGroup.NavigationFolders.Add(objFolder)
Read more about that in the Add a Folder to the Favorite Folders Group article.
Also, you may find the Folder.AddToPFFavorites method which adds a Microsoft Exchange public folder to the public folder's Favorites folder helpful.

Organise e-mails by domain; move into #sender.com folder

I'm trying to get my head around how I would write an inbox to maintain an inbox with subfolders listed by domain e.g. :
Inbox->#client1.com->client1 e-mails
I had a poke around on here and this is close to what I'm trying to get at:
Move e-mails by senderemailaddress outlook macro
Option Explicit
Public Sub Move_Items()
'// Declare your Variables
Dim Inbox As Outlook.MAPIFolder
Dim SubFolder As Outlook.MAPIFolder
Dim Folder As Outlook.MAPIFolder '<- has been added
Dim olNs As Outlook.NameSpace
Dim Item As Outlook.MailItem
Dim Items As Outlook.Items
Dim lngCount As Long
' On Error GoTo MsgErr
'// Set Inbox Reference
Set olNs = Application.GetNamespace("MAPI")
Set Inbox = olNs.GetDefaultFolder(olFolderInbox)
Set Folder = Application.Session.PickFolder
Set Items = Inbox.Items
'// Loop through the Items in the folder backwards
For lngCount = Inbox.Items.Count To 1 Step -1
Set Item = Inbox.Items.Item(lngCount)
Debug.Print Item.Subject
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'bb#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
' // Email_Two
Case "aa#gmail.com"
' // Set SubFolder of Inbox
Set SubFolder = Inbox.Folders("Temp")
Set Item = Items.Find("[SenderEmailAddress] = 'aa#gmail.com'")
If TypeName(Item) <> "Nothing" Then
' // Mark As Read
Item.UnRead = False
' // Move Mail Item to sub Folder
Item.Move SubFolder
End If
End Select
End If
Next lngCount
MsgErr_Exit:
Set Inbox = Nothing
Set SubFolder = Nothing
Set olNs = Nothing
Set Item = Nothing
Set Items = Nothing
Exit Sub
'// Error information
MsgErr:
MsgBox "An unexpected Error has occurred." _
& vbCrLf & "Error Number: " & Err.Number _
& vbCrLf & "Error Description: " & Err.Description _
, vbCritical, "Error!"
Resume MsgErr_Exit
End Sub
What it is missing is the automation piece however, I'm looking for a "run and file" approach where it checks if the subfolder exists. (e.g. #client1.com)
If the subfolder does exist and the domain matches, move the e-mail there. If it does not, create new subfolder for the client with a new domain and file it in there.
Can anyone assist?
Simply use Right - Len - Instr and Split Function
Example
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
Once you have FolderName then check if folder Exists or else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
'// Function - Check folder Exist
Private Function FolderExists(Inbox As MAPIFolder, 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
Your code should look like
If Item.Class = olMail Then
Select Case Item.SenderEmailAddress
' // Email_One
Case "bb#gmail.com"
' // Set SubFolder of Inbox
Dim FolderName As String
FolderName = Right("bb#gmail.com", _
Len("bb#gmail.com") _
- InStr("bb#gmail.com", "#"))
Debug.Print FolderName 'Immediate Window prints gmail.com
FolderName = "#" & FolderName
Debug.Print FolderName 'Immediate Window prints #gmail.com
'// Check if folder exist else create one
If FolderExists(Inbox, FolderName) = True Then
Set SubFolder = Inbox.Folders(FolderName)
Else
Set SubFolder = Inbox.Folders.Add(FolderName)
End If
Add your Private Function FolderExists after End Sub

VBA Outlook - Run automatically for all email in inbox?

I have the following code which I am using to save an email attachment into a folder. I want to make this vba run automatically each time I open outlook and check all emails in my creditchecks#hewden.co.uk inbox (non default inbox).
At the moment though it only checks the email which is selected in the active inbox. can someone please show me how I can edit my code to get it to do what I need. thanks
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
Set objSelection = objOL.ActiveExplorer.Selection
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
Just need to edit some lines. Use something like objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk") to a folder in the same level of your Inbox folder. Here is your code modified:
Public Sub SaveAttachments()
Dim objOL As Outlook.Application
Dim objMsg As Outlook.MailItem 'Object
Dim objAttachments As Outlook.Attachments
Dim objSelection As Outlook.Selection
Dim i As Long
Dim lngCount As Long
Dim strFile As String
Dim strFolderPath As String
Dim strDeletedFiles As String
Dim withParts As String
Dim withoutParts As String
' Get the path to your My Documents folder
On Error Resume Next
' Instantiate an Outlook Application object.
Set objOL = CreateObject("Outlook.Application")
' Get the collection of selected objects.
'Set objSelection = objOL.ActiveExplorer.Selection
'Istead set this to the selected objects you just need to set to your email folder
'This is for a inbox same level folder
Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Parent.Folders("credutchecks#hewden.co.uk")
'This is for a folder inside the inbox folder
'Set objSelection = objOL.GetNamespace("MAPI").GetDefaultFolder(olFolderInbox).Folders("credutchecks#hewden.co.uk")
' The attachment folder needs to exist
' You can change this to another folder name of your choice
' Set the Attachment folder.
strFolderPath = "\\UKSH000-FILE06\Purchasing\New_Supplier_Set_Ups_&_Audits\ATTACHMENTS\"
' Check each selected item for attachments.
For Each objMsg In objSelection
Set objAttachments = objMsg.Attachments
lngCount = objAttachments.Count
If lngCount > 0 Then
' Use a count down loop for removing items
' from a collection. Otherwise, the loop counter gets
' confused and only every other item is removed.
For i = lngCount To 1 Step -1
' Get the file name.
strFile = objAttachments.item(i).FileName
If Right(strFile, 3) = "pdf" Then
' Combine with the path to the Temp folder.
withParts = strFile
withoutParts = Replace(withParts, ".pdf", "")
strFile = strFolderPath & withoutParts & "\" & strFile
' Save the attachment as a file.
objAttachments.item(i).SaveAsFile strFile
End If
Next i
End If
Next
ExitSub:
Set objAttachments = Nothing
Set objMsg = Nothing
Set objSelection = Nothing
Set objOL = Nothing
End Sub
To run it automatically when the Outlook starts just put it on the 'ThisOutlookSession' in the objects folder and name it 'Sub Application_Startup()'. Don't forget to enable macros before.

Get MAPI Folder in Outlook from Folder Path

I am trying to use the function from on this page: http://www.outlookcode.com/d/code/getfolder.htm to use the folder path to navigate to a folder. (I will copy that code onto the bottom of this question--I used it as-is, unmodified at all.) The reason I need to use this is that the default inbox in Outlook is not the same as the inbox I need to be active. I know the path of the relevant inbox by right clicking on it and hit properties, and looking at location.
This is the code I use:
Set objOutlook = CreateObject("Outlook.Application", "localhost")
Set objNamespace = objOutlook.GetNamespace("MAPI")
Set Inbox = GetFolder("\\itadmin#email.org\inbox")
Debug.Print Inbox '<-- This fails
Set InboxItems = Inbox.Items '<-- This also fails
InboxItems.SetColumns ("SentOn")
This returns runtime error 91, Object variable or With block variable not set.
I have no idea what this means. If you could help me solve this error, that would be awesome, and if you have a way that I could avoid this problem entirely, that would be awesome also. Thanks!
Public Function GetFolder(strFolderPath As String)As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
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 objApp = Nothing
End Function
I found the answer. Turns out it's something stupid, as per usual :)
Set Inbox = GetFolder("\\itadmin#email.org\inbox")
needs to be
Set Inbox = GetFolder("itadmin#email.org/inbox")
. This fixes the problem. I figured I would leave this here in case anyone else has this problem, the solution is simply to follow the given format...
Just add this line...
strFolderPath = Replace(strFolderPath, "\\", "")
Apparently also needs this line:
strFolderPath = Replace(strFolderPath, "\", "/")
But after the previous line.
So, in context:
strFolderPath = Replace(strFolderPath, "\\", "")
strFolderPath = Replace(strFolderPath, "\", "/")

Moving Emails to Public Folder using Dynamic Paths

In our Corporate environment we have a Mailbox (not the default inbox) with many sub folders. We also have a Public Folder which is an exact mirror of the Mailbox folder structure.
I am trying to detect the path of a selected email and move that email to its mirrored folder in the Public Folders.
I would say 95% of this code is correct but I am left with an Outlook error message "Can't move the items."
The code is supposed to do the following:
1. detects the current folder of the selected email(s)
2. converts the MAPIFolder into a path string
3. shortens the string to remove the root Mailbox directory structure
4. adds the remaining string onto the root directory structure of the public folder
5. converts the resulting path back into a MAPIFolder
6. move the selected email(s) to the mirrored folder in the Public Folders
Sub PublicFolderAutoArchive()
Dim olApp As Object
Dim currentNameSpace As NameSpace
Dim wipFolder As MAPIFolder
Dim objFolder As MAPIFolder
Dim pubFolder As String
Dim wipFolderString As String
Dim Messages As Selection
Dim itm As Object
Dim Msg As MailItem
Dim Proceed As VbMsgBoxResult
Set olApp = Application
Set currentNameSpace = olApp.GetNamespace("MAPI")
Set wipFolder = Application.ActiveExplorer.CurrentFolder
Set Messages = ActiveExplorer.Selection
' Destination root directory'
' Tried with both "\\Public Folders" and "Public Folders" .. neither worked
pubFolder = "\\Public Folders\All Public Folders\InboxMirror"
' wipFolder.FolderPath Could be any folder in our mailbox such as:
' "\\Mailbox - Corporate Account\Inbox\SubFolder1\SubFolder2"
' however, the \\Mailbox - Corporate Account\Inbox\" part is
' static and never changes so the variable below removes the static
' section, then the remainder of the path is added onto the root
' of the public folder path which is an exact mirror of the inbox.
' This is to allow a dynamic Archive system where the destination
'path matches the source path except for the root directory.
wipFolderString = Right(wipFolder.FolderPath, Len(wipFolder.FolderPath) - 35)
' tried with and without the & "\" ... neither worked
Set objFolder = GetFolder(pubFolder & wipFolderString & "\")
If Messages.Count = 0 Then
Exit Sub
End If
For Each itm In Messages
If itm.Class = olMail Then
Proceed = MsgBox("Are you sure you want archive the message to the Public Folder?", _
vbYesNo + vbQuestion, "Confirm Archive")
If Proceed = vbYes Then
Set Msg = itm
Msg.Move objFolder
End If
End If
Next
End Sub
Public Function GetFolder(strFolderPath As String) As MAPIFolder
' strFolderPath needs to be something like
' "Public Folders\All Public Folders\Company\Sales" or
' "Personal Folders\Inbox\My Folder"
Dim objApp As Outlook.Application
Dim objNS As Outlook.NameSpace
Dim colFolders As Outlook.Folders
Dim objFolder As Outlook.MAPIFolder
Dim arrFolders() As String
Dim I As Long
On Error Resume Next
strFolderPath = Replace(strFolderPath, "/", "\")
arrFolders() = Split(strFolderPath, "\")
Set objApp = Application
Set objNS = objApp.GetNamespace("MAPI")
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 objApp = Nothing
End Function
Note: The mailbox above is just an example and is not the actual mailbox name. I used MsgBox to confirm the path string was being joined correctly with all appropriate back slashes and that the Right() function was getting what I needed from the source path.
I'm not sure, but should be something like?
set objApp = New Outlook.Application
instead of
set objApp = Application
From glancing at the code, it appears that your GetFolder() implementation doesn't like the double-backslash you're giving at the start of the path. There's even a comment indicating this at the start of the function. Try removing those two chars from the front of pubFolder.
Alternatively, you could alter GetFolder to permit them. A few lines like this should do the trick.
If Left(strFolderPath, 2) = "\\" Then
strFolderPath = Right(strFolderPath, Len(strFolderPath) - 2)
End If