View Single Post
 
Old 07-27-2017, 04:58 PM
geodekl geodekl is offline
Centurion
 
Join Date: Feb 2004
Posts: 141
Default Code for this question

Code:
Sub Empty_Folder()

    Dim myNamespace As Outlook.NameSpace
    Dim currFolder As Outlook.Folder
    Dim destComplete As Outlook.Folder
    Dim destInbox As Outlook.Folder
    Dim myCompleteItems As Outlook.Items
    Dim myNotCompleteItems As Outlook.Items
    Dim myMissingCountItems As Outlook.Items
    Dim ufield As Outlook.UserProperty
    Dim MailItem As Outlook.MailItem
    Dim intC%, intNC%, intASK%, intMCnt%, tStr$
    
    Set myNamespace = Application.GetNamespace("MAPI")
    Set currFolder = Outlook.Application.ActiveExplorer.CurrentFolder
    Set ufield = Nothing
    
'ensure selected folder is not empty
    If currFolder.Items.Count = 0 Then
        MsgBox ("Empty folder selected. Nothing to do." & vbCr _
            & "Please check folder selection and try again.")
            Set currFolder = Nothing
            Set myNamespace = Nothing
        Exit Sub
    End If

'find the correct inbox and complete folders (using ASC Faxes and Regions 1-7)
Select Case Replace _
(Left(currFolder.FolderPath, InStr(3, currFolder.FolderPath, "\", vbTextCompare)), "\", "")

Case "ASC Faxes":
    Set destInbox = myNamespace.Folders.Item("ASC Faxes") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Faxes") _
        .Folders.Item("ASC Faxes Team") _
        .Folders.Item("zWeekly Completed ASC Faxes")
Case "ASC Reg 1":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 1") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 1") _
        .Folders.Item("ASC REGION 1 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 1")
Case "ASC Reg 2":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 2") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 2") _
        .Folders.Item("ASC REGION 2 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 2")
Case "ASC Reg 3":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 3") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 3") _
        .Folders.Item("ASC REGION 3 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 3")
Case "ASC Reg 4":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 4") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 4") _
        .Folders.Item("ASC REGION 4 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 4")
Case "ASC Reg 5":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 5") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 5") _
        .Folders.Item("ASC REGION 5 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 5")
Case "ASC Reg 6":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 6") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 6") _
        .Folders.Item("ASC REGION 6 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 6")
Case "ASC Reg 7":
    Set destInbox = myNamespace.Folders.Item("ASC Reg 7") _
        .Folders.Item("Inbox")
    Set destComplete = myNamespace.Folders.Item("ASC Reg 7") _
        .Folders.Item("ASC REGION 7 TEAM") _
        .Folders.Item("zWeekly Completed ASC Reg 7")
Case Else:
    Set currFolder = Nothing
    Set myCompleteItems = Nothing
    Set myNamespace = Nothing
    Set myNotCompleteItems = Nothing
    Set ufield = Nothing
    MsgBox ("Invalid folder selected." & vbCr _
        & "Please select a folder in either the ASC Faxes Team" _
        & vbCr & "or ASC Regions 1-7 Teams, and try again.")
    Exit Sub
End Select
    

'test whether folder is valid and exit if not
If currFolder Is Nothing Then 'ifCurr
    GoTo errorhandler
Else

    Set myCompleteItems = currFolder.Items.Restrict("[FlagStatus] = 1")
        intC = myCompleteItems.Count
    Set myMissingCountItems = currFolder.Items.Restrict("[FlagStatus] = 2")
        intMCnt = myMissingCountItems.Count
    Set myNotCompleteItems = currFolder.Items.Restrict("[FlagStatus] = 0")
        intNC = myNotCompleteItems.Count
        
'confirm actions
            If intMCnt > 0 Then
            tStr = _
                vbCr & vbCr & _
                "Items with the ""missing counts"" flag will not be" _
                & vbCr & "moved. You must use either the checkmark" _
                & vbCr & "tool or the erase tool to set the correct flag" _
                & vbCr & "before attempting to move them."""
            Else
                tStr = ""
            End If
intASK = MsgBox("You are about to move " _
            & intNC & " items to " _
            & vbCr & destInbox.FullFolderPath _
            & vbCr & "and " & intC & " item(s) to " _
            & vbCr & destComplete.FullFolderPath & "." _
            & tStr _
            & vbCr & vbCr & "Select ""OK"" to proceed, or ""Cancel""" _
            & vbCr & "to exit without making any changes.", _
            vbOKCancel)
If intASK = vbCancel Then
    Set currFolder = Nothing
    Set myCompleteItems = Nothing
    Set myNamespace = Nothing
    Set myNotCompleteItems = Nothing
    Set ufield = Nothing
    MsgBox ("Action Canceled")
    Exit Sub
End If

'track and move completed items
Do While Not myCompleteItems.Count = 0
'reload the collection to resolve changes caused by the move operation
Set myCompleteItems = currFolder.Items.Restrict("[FlagStatus] = 1")
Set MailItem = myCompleteItems.Item(1)
On Error Resume Next
    'search for the Tracking field, then add it if necessary
    Set ufield = Nothing 'make sure nothing has carried over from previous operations
    Set ufield = MailItem.UserProperties.Find("ChangeTracking", True)
        If ufield Is Nothing Then
            'add the Tracking field
            Set ufield = MailItem.UserProperties.Add("ChangeTracking", _
            Outlook.OlUserPropertyType.olText)
        End If
    'set the Tracking field value
        ufield.Value = ufield.Value & vbCr & "---------------------" & vbCr _
        & Now & " Item moved to completed from" & vbCr _
        & currFolder.FolderPath & vbCr _
        & "by " & Application.Session.CurrentUser.Name
        MailItem.Move destComplete
'Debug.Print MailItem.ReceivedTime
Err.Clear
Loop

'track and move items not completed
Do While Not myNotCompleteItems.Count = 0
'reload the collection to resolve changes caused by the move operation
Set myNotCompleteItems = currFolder.Items.Restrict("[FlagStatus] = 0")
'search for and remove the Rep field
Set MailItem = myNotCompleteItems.Item(1)
On Error Resume Next
'remove the Rep field
    MailItem.UserProperties.Item("Rep").Delete
'remove the Folder Location field
    MailItem.UserProperties.Item("FolderLocation").Delete
'search for the Tracking field, then add it if necessary
    Set ufield = Nothing 'make sure nothing has carried over from previous operations
    Set ufield = MailItem.UserProperties.Find("ChangeTracking", True)
        If ufield Is Nothing Then
            'add the Tracking field
            Set ufield = MailItem.UserProperties.Add("ChangeTracking", _
            Outlook.OlUserPropertyType.olText)
        End If
'set the Tracking field value
    ufield.Value = ufield.Value & vbCr & "---------------------" & vbCr _
    & Now & " Item returned to inbox from" & vbCr _
    & currFolder.FolderPath & vbCr _
    & "by " & Application.Session.CurrentUser.Name
    MailItem.Move destInbox
Err.Clear
Loop

'if there are still email items in the folder, it means they are not correctly tagged.
'display a message to the user before continuing.
If currFolder.Items.Count > 0 Then
MsgBox "There are " & currFolder.Items.Count & " items which could not be moved." _
    & vbCr & vbCr & "Please run the ""clear tags"" tool (pink eraser) on all unfinished items," _
    & vbCr & "and the ""bank your work"" tool (piggy bank) on all completed items," _
    & vbCr & "to prepare them to be moved; then run this macro (eightball) again." _
    & vbCr & vbCr & "Thank you."
    
    Set currFolder = Nothing
    Set myCompleteItems = Nothing
    Set myNamespace = Nothing
    Set myNotCompleteItems = Nothing
    Set ufield = Nothing
    MsgBox ("Task Complete.")
    Exit Sub
End If

'this is the end of the "if currFolder is Nothing" statement
End If 'ifCurr


GoTo cleanup 'this bypasses errorhandler if it isn't explicity called
errorhandler:
    Set currFolder = Nothing
    Set myCompleteItems = Nothing
    Set myNamespace = Nothing
    Set myNotCompleteItems = Nothing
    Set ufield = Nothing
    MsgBox ("An unexpected error has occurred." & vbCr _
        & "Please ensure you have a valid" & vbCr _
        & "folder selected and try again." & vbCr & vbCr _
        & "If the error persists, please notify Kat Land.")
    Exit Sub
cleanup:
    Set currFolder = Nothing
    Set myCompleteItems = Nothing
    Set myNamespace = Nothing
    Set myNotCompleteItems = Nothing
    Set ufield = Nothing
    MsgBox ("Task Complete.")
End Sub
Reply With Quote