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

Open in new window

tonelm54Asked:
Who is Participating?
 
David LeeConnect With a Mentor Commented:
Hi, tonelm54.

Some of that code looks like something I might have written at some point.  Here's a simpler approach to what you've said you want to accomplish.  This code searches through the inbox and all folders below it for items marked as complete.  Complete in this case means that the item has been flagged as complete.  All items so marked are moved to the archive folder.  Follow these instructions to use this.

1.  Start Outlook
2.  Click Tools > Macro > Visual Basic Editor
3.  If not already expanded, expand Microsoft Office Outlook Objects
4.  If not already expanded, expand Modules
5.  Select an existing module (e.g. Module1) by double-clicking on it or create a new module by right-clicking Modules and selecting Insert > Module.
6.  Copy the code from the Code Snippet box and paste it into the right-hand pane of Outlook's VB Editor window
7.  Edit the code as needed.  I included comments wherever something needs to or can change
8.  Click the diskette icon on the toolbar to save the changes
9.  Close the VB Editor

Run the macro ArchiveCompleted.

Private olkArchiveFolder As Outlook.MAPIFolder
 
Sub ArchiveCompleted()
    'Change the folder path on the next line to that of your archive file and the folder you want the items to be filed in'
    Set olkArchiveFolder = OpenOutlookFolder("Personal Folders\Completed Items)
    ProcessFolder Outlook.Application.Session.GetDefaultFolder(olFolderInbox)
End Sub
 
Sub ProcessFolder(olkFolder As Outlook.MAPIFolder)
    Dim olkSubfolder As Outlook.MAPIFolder, olkItem As Object, intCount As Integer
    For intCount = olkFolder.Items.Count To 1 Step -1
        Set olkItem = olkFolder.Items.Item(intCount)
        If olkItem.FlagStatus = olFlagComplete Then
            olkItem.Move olkArchiveFolder
        End If
    Next
    For Each olkSubfolder In olkFolder.Folders
        ProcessFolder olkSubfolder
    Next
    Set olkSubfolder = Nothing
End Sub
 
Function IsNothing(obj)
  If TypeName(obj) = "Nothing" Then
    IsNothing = True
  Else
    IsNothing = False
  End If
End Function
 
Function OpenOutlookFolder(strFolderPath As String) As Outlook.MAPIFolder
    Dim arrFolders As Variant, _
        varFolder As Variant, _
        olkFolder As Outlook.MAPIFolder
    On Error GoTo ehOpenOutlookFolder
    If strFolderPath = "" Then
        Set OpenOutlookFolder = Nothing
    Else
        Do While Left(strFolderPath, 1) = "\"
            strFolderPath = Right(strFolderPath, Len(strFolderPath) - 1)
        Loop
        arrFolders = Split(strFolderPath, "\")
        For Each varFolder In arrFolders
            If IsNothing(olkFolder) Then
                Set olkFolder = Session.Folders(varFolder)
            Else
                Set olkFolder = olkFolder.Folders(varFolder)
            End If
        Next
        Set OpenOutlookFolder = olkFolder
    End If
    On Error GoTo 0
    Exit Function
ehOpenOutlookFolder:
    Set OpenOutlookFolder = Nothing
    On Error GoTo 0
End Function

Open in new window

0
 
tonelm54Author Commented:
..
0
 
peakpeakCommented:
0
Free Tool: ZipGrep

ZipGrep is a utility that can list and search zip (.war, .ear, .jar, etc) archives for text patterns, without the need to extract the archive's contents.

One of a set of tools we're offering as a way to say thank you for being a part of the community.

 
peakpeakCommented:
0
 
David LeeCommented:
That could arguably be said about any bit of code.  
0
 
tonelm54Author Commented:
The code works great, apart from when it sees reports, Ive raised another question for this, as it is a new question Q_24304821
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.