Determine Selected Folder and Selected Item in Folder
I finished the code that I started and find that the program works
rather well. I filter most mail that comes into my inbox to other
folders for review. Upon review, many remain in a subfolder or
subfolders of that particular folder. Moving the mail item using
Outlook's move to dialog or dragging is fine if you only do this every
once in a while. If you do it a lot, it becomes a pain.
I decided it would be great to just have a button to click on that knows
to move the selected item to the subfolder of the active folder. Also,
if there are more than one subfolders, I have a list box pop up listing
only the subfolders of the active folder. This works much better than
having a full tree of folders to have to navigate. I note that this
works well even as the folder tree grows to subfolders of subfolders.
For anyone interested in trying this, I provide the code below and
welcome suggestions on how to improve it or warnings on any dangers
inherent in it. I'm new at Outlook VBA and there is probably a lot of
superfluous code in it.
You may need to change the next statement since my system says "Personal
Folders" Set objPF = objNS.Folders("Personal Folders"). Yours may be
different.
I have this set up to only allow single selections. It can be modified
for multiple selections.
To run this program you need to create a userform and name it fmListFolders.
You need to put a listbox on it and name it lbFolderList.
You need a commandbutton and name it OKButton.
In the code for the userform put the Sub OKButton_Click.
In module 1, put the rest of the code with a Public variable named
choice at the top of the module. For some reason, I was not able to
retain the value of the form in a public variable.
Since variables in a form are lost after unloading, a public variable is
supposed to work. I tried putting Public choice in both modules and
alone in each and could not get the variable to retain its value under
any scenario. I had to do a work around with the function
get_val(choice) which left the userform before its dismissal and stored
the value in the code module. If anyone has an idea why or how I should
have done this, I'd appreciate hearing about it.
I move the item to another folder based on the subject name. I'm not
sure if this is the best way to do this or if erroneous results could
occur. I'd appreciate any opinion on that also.
Here's my code:
'==================== Userform Code ========================
Private Sub OKButton_Click()
On Error GoTo ErrorHandler
choice = "" 'Initialize choice
'Check if anything is selected in listbox
'If selected, store in public variable choice
If lbFolderList.ListIndex <> -1 Then
For i = 0 To lbFolderList.ListCount - 1
If lbFolderList.Selected(i) Then
choice = lbFolderList.List(i)
Exit For
End If
Next i
End If
holding = get_val(choice) 'Store choice in module1
Unload fmListFolders
Exit Sub
ErrorHandler:
Call Error_Message
End Sub
'=================End Userform Code===========================
'=================== Module1 Code ============================
Public choice
Sub move_selected_item_multiple_subfolders()
'This is the sub that runs when an Outlook toolbar button is clicked.
'A mailitem should already have been selected when running the code.
Dim objNS As NameSpace
Dim objPF As MAPIFolder
Dim objSub_Folder As MAPIFolder
Dim objCur_Folder As MAPIFolder
Dim objitem As MailItem
On Error GoTo ErrorHandler
choice = "Initialize as Unselected" 'Initialize choice
Set objitem = GetCurrentItem() 'Call function
Set objNS = Application.GetNamespace("MAPI")
Set objPF = objNS.Folders("Personal Folders")
If objitem Is Nothing Then
MsgBox "No mail item has been selected"
Exit Sub
End If
'Determine the name of the folder the
'mailitem is in
Set objCur_Folder = objitem.Parent
'Determine the subject of the mailitem
'for identication purposes
'There is probably something better to
'use than the item's subject.
mail_subject = mail_item_subject() 'Call function
If mail_subject = "" Then
Exit Sub
End If
If objCur_Folder.Folders.Count > 1 Then
For X = 1 To objCur_Folder.Folders.Count
fmListFolders.lbFolderList.AddItem objCur_Folder.Folders(X)
Next X
fmListFolders.Show
If choice = "" Then
MsgBox "Nothing was selected."
Exit Sub
End If
ElseIf objCur_Folder.Folders.Count < 1 Then
MsgBox "There is no subfolder to move the selection to."
Exit Sub
Else
choice = objCur_Folder.Folders(1)
End If
Set objSub_Folder = objCur_Folder.Folders(choice)
objCur_Folder.Items(mail_subject).Move objSub_Folder
Exit Sub
ErrorHandler:
Call Error_Message
End Sub
'===================================================================
Function GetCurrentItem() As Object
Dim objApp As Application
Dim objSel As Selection
Dim objitem As MailItem
Dim objempty As Object
On Error GoTo ErrorHandler
Set objApp = CreateObject("Outlook.Application")
Select Case objApp.ActiveWindow.Class
Case olExplorer
Set objSel = objApp.ActiveExplorer.Selection
If objSel.Parent = "Calendar" Or objSel.Parent = "Contacts"
Or objSel.Parent = "Drafts" Or _
objSel.Parent = "Journal" Or objSel.Parent = "Notes" Or objSel.Parent =
"Outbox" Or _
objSel.Parent = "Sent Items" Or objSel.Parent = "Tasks" Then
MsgBox "A mail folder item must be chosen!"
Exit Function
End If
If objSel.Count > 0 Then
Set objitem = objSel.Item(1)
End If
Case olInspector
Set objitem = objApp.ActiveInspector.CurrentItem
Case Else
' can't handle any other kind of window
End Select
Set GetCurrentItem = objitem
Set objitem = Nothing
Set objSel = Nothing
Set objApp = Nothing
Exit Function
ErrorHandler:
Call Error_Message
End Function
'===================================================================
Function mail_item_subject()
'Determine the mail item's subject
Dim myOlApp As New Outlook.Application
Dim myOlExp As Outlook.Explorer
Dim myOlSel As Outlook.Selection
Dim CC As MailItem
On Error GoTo ErrorHandler
Set myOlExp = myOlApp.ActiveExplorer
Set myOlSel = myOlExp.Selection
If myOlSel.Count < 1 Then
MsgBox "No selection was made."
mail_item_subject = ""
Exit Function
ElseIf myOlSel.Count > 1 Then
MsgBox "Only one item can be selected at a time."
mail_item_subject = ""
Exit Function
End If
mail_item_subject = myOlSel.Item(1)
Exit Function
ErrorHandler:
Call Error_Message
End Function
'===================================================================
Function get_val(incoming)
'I had to write this little maneuver because I could
'not get the public variable choice to retain
'its value after the userform unloaded.
On Error GoTo ErrorHandler
choice = incoming
get_val = incoming
Exit Function
ErrorHandler:
Call Error_Message
End Function
'===================================================================
Sub Error_Message()
If Err.Number <> 0 Then
Msg = "Error # " & Str(Err.Number) & " was generated by " _
& Err.Source & Chr(13) & Err.Description
MsgBox Msg, , "Error", Err.HelpFile, Err.HelpContext
End If
End Sub
'======================= End Module1 Code===========================
