Moving Emails to Public Folder using Dynamic Paths - vba

Question

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.

Answer 1

I'm not sure, but should be something like?
set objApp = New Outlook.Application
instead of
set objApp = Application

Answer 2

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