Outlook VBA - new Run-time Error occurring when using Move Folder code - Call was rejected by callee

[dougmarkham]

Hi Folks,

I use an excel worksheet to direct the movement of folders in outlook. Outlook VBA calls the excel workbook and finds the move from, move to columns etc.

I have been working from home no issues, but then I've connected back onto the company network this morning at the office and gotten the following error (see attached image).
My other outlook VBA is functioning (to create folders, rename folders etc).

Here is the code (below). The line that's errored is

ExcelApp.Visible = True

suggesting that outlook is failing to open excel?

Option Explicit

Public Sub Move_Folders()

    Dim workbookFileName    As String
    Dim workbookOpened      As Boolean
    Dim ExcelApp            As Object
    Dim ExcelWb             As Object
    Dim ExcelSh             As Object
    Dim lastRow             As Long
    Dim r                   As Long
    Dim outSourceFolder     As Outlook.MAPIFolder
    Dim outDestFolder       As Outlook.MAPIFolder
   
    Const cExcelWorkbook As String = "S:\APS_Logistics\Logistics Support\Dougs jobs\Time-manager.xlsm"     'CHANGE THIS
   
    On Error Resume Next
    Set ExcelApp = GetObject(, "Excel.Application")
    If Err.Number <> 0 Then
        Set ExcelApp = CreateObject("Excel.Application")
    End If
    On Error GoTo 0
   
    workbookFileName = Dir(cExcelWorkbook)
    'MsgBox workbookFileName
    If workbookFileName <> vbNullString Then
        Set ExcelWb = Nothing
        workbookOpened = False
        On Error Resume Next
        Set ExcelWb = ExcelApp.Workbooks(workbookFileName)
        If ExcelWb Is Nothing Then
            Set ExcelWb = ExcelApp.Workbooks.Open(cExcelWorkbook, ReadOnly:=True, Password:="asdfjkl;")
            workbookOpened = True
        End If
        On Error GoTo 0
    Else
        MsgBox cExcelWorkbook & " not found"
        Exit Sub
    End If
   
    ExcelApp.Visible = True
    Application.ActiveExplorer.Activate
   
    Set ExcelSh = ExcelWb.Worksheets("MoveFolders")
    With ExcelSh
   
        lastRow = ExcelSh.cells(.rows.Count, 1).End(xlUp).Row
       
        For r = 2 To lastRow
           
            Set outSourceFolder = Get_Folder(ExcelSh.cells(r, 1).Value)
            Set outDestFolder = Get_Folder(ExcelSh.cells(r, 2).Value)
           
            If Not outSourceFolder Is Nothing And Not outDestFolder Is Nothing Then
       
                outSourceFolder.MoveTo outDestFolder
                MsgBox "Row " & r & vbCrLf & _
                       outSourceFolder.folderPath & vbCrLf & _
                       "moved to " & vbCrLf & _
                       outDestFolder.folderPath
               
            Else
           
                MsgBox "Row " & r & vbCrLf & _
                       IIf(outSourceFolder Is Nothing, "Source folder '" & .cells(r, 1).Value & "' not found" & vbCrLf, "") & _
                       IIf(outDestFolder Is Nothing, "Destination folder '" & .cells(r, 1).Value & "' not found" & vbCrLf, "")

           
            End If
       
        Next
       
    End With
   
    If workbookOpened Then
        ExcelWb.Close SaveChanges:=False
        ExcelApp.Quit
        Set ExcelWb = Nothing
        Set ExcelApp = Nothing
    End If


End Sub


Private Function Get_Folder(folderPath As String, Optional ByVal outStartFolder As MAPIFolder) As MAPIFolder
   
    'Search for the specified folder path starting at the optional MAPI start folder.
    '
    'If outStartFolder is specified then start in that folder and search for the specified folder path.
    'If outStartFolder is not specified then the search starts at the specified folder path.  The folder path
    'can start with a top-level folder by prepending the folder path with "\\".  Folder names are separated by "\".
    '
    'Examples:
    '   "\\Account Name\Folder1\Subfolder1\Sub-Subfolder1"  - folders in main (active) top-level folder
    '   "\\Archive Folders\Folder1\Subfolder1"              - folders in archive folder
    '   "Folder1\Subfolder1\Sub-Subfolder1"                 - folders in main (active) top-level folder
    '
    'If the whole subfolder path is found this function returns the last subfolder as a MAPIFolder object, otherwise
    'it returns Nothing
   
    Dim NS As NameSpace
    Dim outFolder As MAPIFolder
    Dim outFolders As folders
    Dim folders As Variant
    Dim i As Long
   
    Set NS = Application.GetNamespace("MAPI")
   
    If outStartFolder Is Nothing Then
   
        If Left(folderPath, 2) = "\\" Then
           
            'folderPath starts with a top level folder ("\\Folder name\xxx\yyy"), so look for that
            'folder and if found set outStartFolder to it
           
            folders = Split(Mid(folderPath, 3), "\")
            Set outFolders = NS.folders
            Set outStartFolder = Nothing
            i = 1
            While i <= outFolders.Count And outStartFolder Is Nothing
                Set outFolder = outFolders(i)
                If outFolder.Name = folders(0) Then Set outStartFolder = outFolder
                i = i + 1
            Wend
           
            i = 1   'match folder paths from 2nd folder in path
           
        Else
       
            'Top level folder not specified, so start subfolders search at parent folder of the Inbox
           
            Set outStartFolder = NS.GetDefaultFolder(olFolderInbox).Parent
            folders = Split(folderPath, "\")
            i = 0
           
        End If
       
    Else
   
        folders = Split(folderPath, "\")
        i = 0
   
    End If
   
    Set outFolder = outStartFolder
    While i <= UBound(folders) And Not outFolder Is Nothing
        If folders(i) <> "" Then
            Set outFolder = Nothing
            On Error Resume Next
            Set outFolder = outStartFolder.folders(folders(i))
            On Error GoTo 0
            Set outStartFolder = outFolder
        End If
        i = i + 1
    Wend
   
    Set Get_Folder = outFolder
   
End Function

Does anyone know why this error message occurs and how to fix it?

Kind regards,

Doug