Outlook VBA, moving completed to Archive

Im trying to write some code, to scan through my inbox folders, and anything I have ticked to be completed, move into my archive folder.

Problem is, I cant seem to get it past the line:-
Set myInputFolder = myInbox.Folders(GetFolder(Mid(srcFolder, InStr(Mid(srcFolder, 3), "\") + 3)))

Which should just be saying what folder its scanning, in the first case 'Inbox'.

Any ideas?

Sub ArchiveCompleted()
    SearchFolder GetFolder("Mailbox\Inbox"), "Archive 2009"
End Sub
 
Sub SearchFolder(olkFolder As Outlook.MAPIFolder, destPST As String)
    Dim olkSubfolder As Outlook.MAPIFolder
 
    For Each olkSubfolder In olkFolder.Folders
        SearchFolder olkSubfolder, destPST
        MoveItems olkFolder.FolderPath, destPST & Mid(olkSubfolder.FolderPath, InStr(3, olkSubfolder.FolderPath, "\"))
    Next
    Set olkSubfolder = Nothing
End Sub
 
 
 
Sub MoveItems(srcFolder As String, desFolder As String)
 
    Dim myolAPP As New Outlook.Application
    Dim myNameSpace As Outlook.NameSpace
    Dim myInbox As Outlook.MAPIFolder
    Dim myInputFolder As Outlook.MAPIFolder
    Dim myDestFolder As Outlook.MAPIFolder
    Dim myItems As Outlook.Items
    Dim myItem As Outlook.MailItem
    Dim Item As Outlook.MailItem
    
    Set myNameSpace = myolAPP.GetNamespace("MAPI")
    Set myInbox = myNameSpace.GetDefaultFolder(olFolderInbox)
       
    'MsgBox Mid(srcFolder, InStr(Mid(srcFolder, 3), "\") + 3)
    'Set myInputFolder = myInbox.Folder
    
    Set myInputFolder = myInbox.Folders(Mid(srcFolder, InStr(Mid(srcFolder, 3), "\") + 3))
    
    
    
    Set myDestFolder = GetFolder(desFolder)
    Set myItems = myInputFolder.Items
    
    While myItems.Count > 0
        For Each Item In myItems
            If Not IsNull(Item.FlagRequest) Then
                Item.Move myDestFolder
            End If
        Next
        Set myItems = myInputFolder.Items
    Wend
 
End Sub
 
 
 
 
Public Function GetFolder(strFolderPath As String) As MAPIFolder
    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 = CreateObject("Outlook.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

Select allOpen in new window