Outlook VBA to move selected email to a public folder

aaroncrt · #1 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

niton · #2 10-21-2013, 05:05 PM

You may find Option Explicit useful.

http://office.blogs.webucator.com/20...plicit-in-vba/

See if this does what you want.

Code:

Option Explicit

Sub MoveProject()

Dim objNS As Outlook.Namespace
Dim projectParentFolder As Outlook.MAPIFolder
Dim objFolder As Outlook.MAPIFolder
Dim objX As Object

Dim strProject As String
Dim Proceed As VbMsgBoxResult
Dim strFolder As String
Dim intX As Long

If Application.ActiveExplorer.Selection.count = 0 Then
    'Require that this procedure be called only when a message is Selected
    MsgBox "Select at least one mailitem", , "MoveProject"
    Exit Sub
End If

strProject = InputBox("Please enter Project")

strProject = Trim(strProject)

If Len(strProject) > 4 Then strProject = Left(strProject, 4)

Set objNS = Application.GetNamespace("MAPI")

' 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 projectParentFolder = objNS.Session.GetDefaultFolder(olPublicFoldersAllPublicFolders).Folders("Projects")

For intX = 1 To projectParentFolder.Folders.count
    If Left(projectParentFolder.Folders.item(intX).name, Len(strProject)) = strProject Then
        Set objFolder = projectParentFolder.Folders.item(intX)
        Exit For
    End If
Next

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

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 " & objFolder & "?", _
            vbYesNo + vbQuestion, "Confirm Move")
        If Proceed = vbYes Then
            objX.Move objFolder
        End If
    End If
Next

exitRoutine:
    Set objX = Nothing
    Set objFolder = Nothing
    Set projectParentFolder = Nothing
    Set objNS = Nothing

End Sub

aaroncrt · #3 10-21-2013, 05:11 PM

Thanks for the reply.

I managed to get it working by searching the Public Folders sub folders for a match to the input variable string.
I added the following.

Code:

ReDim sArray(0) As String
If fld.Folders.Count Then
             
  For i = 1 To fld.Folders.Count
    If Left(fld.Folders(i).Name, 3) = strProject Then
        iElement = IIf(sArray(0) = "", 0, UBound(sArray) + 1)
        ReDim Preserve sArray(iElement) As String
        sArray(iElement) = fld.Folders(i).Name
    End If
  Next i

Similar Threads
Thread	Thread Starter	Forum	Replies	Last Post
Forwarding email from a public folder to my Inbox	ray500	Outlook	2	08-23-2016 07:20 AM
how to move the email directly to secondary mailbox sent item folder	gregory	Outlook	2	04-28-2012 01:21 AM
Outlook for Mac 2011 - public folder drag/drop	LakeShoreDriving	Outlook	0	04-09-2012 11:27 PM
User cannot move email messages within Outlook Inbox folder and sub-folders.	Darsss	Outlook	5	06-06-2011 11:37 PM
Forwarding email from a Public Folder	ray500	Outlook	1	08-20-2010 03:06 PM