Want to protect your cyber security and still get fast solutions? Ask a secure question today.Go Premium

x
  • Status: Solved
  • Priority: Medium
  • Security: Public
  • Views: 1898
  • Last Modified:

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

0
tonelm54
Asked:
tonelm54
  • 2
  • 2
  • 2
1 Solution
 
tonelm54Author Commented:
..
0
 
peakpeakCommented:
0
 
David LeeCommented:
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
Concerto Cloud for Software Providers & ISVs

Can Concerto Cloud Services help you focus on evolving your application offerings, while delivering the best cloud experience to your customers? From DevOps to revenue models and customer support, the answer is yes!

Learn how Concerto can help you.

 
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

Featured Post

What does it mean to be "Always On"?

Is your cloud always on? With an Always On cloud you won't have to worry about downtime for maintenance or software application code updates, ensuring that your bottom line isn't affected.

  • 2
  • 2
  • 2
Tackle projects and never again get stuck behind a technical roadblock.
Join Now