Microsoft Office Forums - View Single Post - Outlook VBA to move selected email to a public folder

aaroncrt · 10-14-2013, 09:48 PM

Hi,

Quick note, I am not too familiar with VBA as I have only created basic scripts for personal use etc.

I am currently creating a script to move a currently selected email to a public folder location based on the input of a user. The main Public Folder path remains static ie 'All Public Folders\Projects\'. The 'Projects' folder however has subfolders all beginning with a number followed by a job name ie '001 - Test Name'

The script prompts for user input, at this point the project number is supplied and is 3-4 numeric digits eg '001'. So far I have it working with folders below 099. Anything above 099, I get a 'Run-time error '440': Array index out of bounds.'
If I type the complete folder name when prompted - eg '254 - Test Name', the email is moved successfully.

Is it as simple as using the wrong variable type?

I was also thinking I may need to search the Public Folder using the input value to find the matching folder and set it as the destination. I am unable to get that part working correctly.

Any help is greatly appreciated.

Here's my example code

Code:

Sub MoveProject()
Dim objFolder As Outlook.MAPIFolder, objInbox As Outlook.MAPIFolder
Dim objNS As Outlook.NameSpace, objItem As Outlook.MailItem
Dim strProject As String
Dim Proceed As VbMsgBoxResult
Set objNS = Application.GetNamespace("MAPI")
Dim appOutlook As New Outlook.Application
Set nms = appOutlook.GetNamespace("MAPI")

strProject = InputBox("Please enter Project")

strFolder = nms.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Parent
' If the public folder location is not \\public folders\ all public folders\projects\001 etc then the below line is required to be changed
Set fld = nms.Folders(strFolder).Folders("All Public Folders").Folders("Projects").Folders(strProject)
    
For intX = 1 To objNS.Folders.Count
If objNS.Folders.Item(intX).Name = "Public Folders" Then

Exit For
End If
Next

'If objFolder Is Nothing Then
'MsgBox "This folder doesn't exist!", vbOKOnly
'End If

If Application.ActiveExplorer.Selection.Count = 0 Then
'Require that this procedure be called only when a message is Selected
Exit Sub
End If

Set oSelection = Application.ActiveExplorer.Selection

For intX = ActiveExplorer.Selection.Count To 1 Step -1
Set objX = ActiveExplorer.Selection.Item(intX)
If objX.Class = olMail Then
    Proceed = MsgBox("Are you sure you want move the message to the Projects Folder " & strProject & "?", _
    vbYesNo + vbQuestion, "Confirm Move")
    If Proceed = vbYes Then
Set objEmail = objX
objEmail.Move fld
    End If
End If
Next


Set objItem = Nothing
Set objFolder = Nothing
Set objInbox = Nothing
Set objNS = Nothing
End Sub