Outlook automation for copying appointments

[Axoliien]

I am trying to automate a system of allowing users to copy their calendar appointments into a team calendar since we have several teams and it can get confusing and messy finding the team calendars and making sure everyone gets the item to the right place. I have been able to get the function to work well and everything seems to go just fine, but I want to tweak the function a bit now and allow a little more power.

Public Sub CopyApptToApplications()
    Dim itemNum As Integer
    Dim objAppt As AppointmentItem
    Dim newAppt As AppointmentItem
    Dim fdrApps As MAPIFolder
    Dim nsMyNameSpace As NameSpace
    Dim apptAdded As Boolean
    Dim msgStr As String, succStr As String
    
    On Error GoTo MoveError
    apptAdded = False
    Set nsMyNameSpace = Application.GetNamespace("MAPI")
    Set fdrApps = nsMyNameSpace.Folders.item("Public Folders").Folders("All Public Folders").Folders("Public Services").Folders("Computer Services").Folders("Applications").Folders("Staff")
    Debug.Print fdrApps
    itemNum = Application.ActiveExplorer.Selection.Count
    If itemNum < 1 Then
        MsgBox "No appointment is selected.", vbOKOnly + vbInformation, "Error: No appointment selected."
        Exit Sub
    End If
    
    For itemNum = 1 To Application.ActiveExplorer.Selection.Count
        'Class 43 Email
        'Class 26 Appointment
        If Application.ActiveExplorer.Selection.item(itemNum).Class <> 26 Then
            msgStr = "At least one item selected was not a valid appointment." & vbCrLf
        Else
            Set objAppt = Application.ActiveExplorer.Selection.item(itemNum)
            Set newAppt = objAppt.Copy
            newAppt.Move fdrApps
            Set newAppt = Nothing
            apptAdded = True
        End If
    Next itemNum
    If apptAdded Then succStr = "Selected appointments have been added to the staff calendar."
    MsgBox msgStr & succStr, vbOKOnly + vbInformation, "Operation Completed"

ClearMem:
    On Error GoTo 0
    Set objAppt = Nothing
    Set newAppt = Nothing
    Set fdrApps = Nothing
    Set nsMyNameSpace = Nothing
    Exit Sub
    
MoveError:
    If (Err.Number = -2147221233) Then 'Cannot find folder
        MsgBox "The destination folder could not be found.  Check your settings and try again.", _
            vbOKOnly + vbInformation, "Cannot find destination folder."
    Else
        MsgBox "An unhandled error has occurred.  Please see the program administrator for assistance." & vbCrLf & _
            "Error " & Err.Number & ": " & Err.Description & vbCrLf & _
            "Source: " & Err.Source, vbOKOnly + vbInformation, "Cannot copy all appointments."
    End If
    GoTo ClearMem
End Sub

First of all, is there any way to set the folder I want to reference without having to break down every single folder? In other words, if I get a path, is there a way I can just reference the path? As above I would want to reference \\Public Folders\All Public Folders\Public Services\Computer Services\Applications\Staff

Next, is there a way I can display an actual form to allow the user to select the destination calendar box in Outlook? I can easily store the information for later use, I just need to know how to display the list of folders and allow them to denote which one they are staff in.

Thanks!