Xtreme Visual Basic Talk

Xtreme Visual Basic Talk (http://www.xtremevbtalk.com/)
-   Word, PowerPoint, Outlook, and Other Office Products (http://www.xtremevbtalk.com/word-powerpoint-outlook-and-other-office-products/)
-   -   Outlook macro "operation failed" (http://www.xtremevbtalk.com/word-powerpoint-outlook-and-other-office-products/328688-outlook-macro-operation-failed.html)

geodekl 07-27-2017 04:56 PM

Outlook macro "operation failed"
 
I use vba code to add custom tags to a collection of email items in the current folder, then move them to a different folder. Occasionally the macro will fail, and one of the folder or collection objects in the locals window will state "operation failed" rather than displaying its contents. When this happens, it is occasionally possible to just stop the macro and try again. More usually, though, it is necessary to close then re-open Outlook before the macro will succeed. My presumption is that this is a server refresh issue - Outlook (or at least the macro) is losing sync with what's happening on the server. How can I force a refresh to obtain the current data set? I should mention, my Outlook account opens roughly a dozen different mailboxes, and we don't use cached exchange mode (it doesn't keep up with the volume of mail we handle). I've tried "send/receive all", but the only thing that consistently works is to completely exit Outlook and start it back up.

geodekl 07-27-2017 04:58 PM

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



All times are GMT -6. The time now is 09:23 PM.

Powered by vBulletin® Version 3.8.9
Copyright ©2000 - 2017, vBulletin Solutions, Inc.
Search Engine Optimisation provided by DragonByte SEO v2.0.15 (Lite) - vBulletin Mods & Addons Copyright © 2017 DragonByte Technologies Ltd.
All site content is protected by the Digital Millenium Act of 1998. Copyright©2001-2011 MAS Media Inc. and Extreme Visual Basic Forum. All rights reserved.
You may not copy or reproduce any portion of this site without written consent.