Solved

Outlook VBA, moving completed to Archive

Posted on 2009-04-07
6
1,745 Views
Last Modified: 2012-08-14
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
Comment
Question by:tonelm54
  • 2
  • 2
  • 2
6 Comments
 

Author Comment

by:tonelm54
ID: 24085970
..
0
 
LVL 28

Expert Comment

by:peakpeak
ID: 24086320
0
 
LVL 76

Accepted Solution

by:
David Lee earned 500 total points
ID: 24092027
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
Control application downtime with dependency maps

Visualize the interdependencies between application components better with Applications Manager's automated application discovery and dependency mapping feature. Resolve performance issues faster by quickly isolating problematic components.

 
LVL 28

Expert Comment

by:peakpeak
ID: 24092053
0
 
LVL 76

Expert Comment

by:David Lee
ID: 24092102
That could arguably be said about any bit of code.  
0
 

Author Comment

by:tonelm54
ID: 24094977
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

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Resolve Outlook connectivity issues after moving mailbox to new Exchange 2016 server
Outlook Free & Paid Tools
Get people started with the process of using Access VBA to control Outlook using automation, Microsoft Access can control other applications. An example is the ability to programmatically talk to Microsoft Outlook. Using automation, an Access applic…
This Experts Exchange video Micro Tutorial shows how to tell Microsoft Office that a word is NOT spelled correctly. Microsoft Office has a built-in, main dictionary that is shared by Office apps, including Excel, Outlook, PowerPoint, and Word. When …

746 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

10 Experts available now in Live!

Get 1:1 Help Now