Outlook 2019 - VBA code not running

Hi everyone
The below code does not run in Outlook 2019. Marco settings set to accept digital Signed macros. Digital Certificate can be found under email trusted publishers. The code below do run on my other pc and laptop with Outlook 2021. I have run mmc. Thx to Graham Mayor. VBA references are the same on both Computers.

Code:

---

Private WithEvents objSentItems As Items

Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub

Public Sub SaveMessageAsMsg()
  Dim oMail As Outlook.MailItem
  Dim objItem As Object
  Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim StrFolderpath As String
  Dim StrUserPath As Variant

'Defaults to Documents folder
StrUserPath = "\\JK_Server-PC\Users\JK_Server\My Documents\JKBrokers\Clients\"
StrFolderpath = BrowseForFolder(StrUserPath)
 
  For Each objItem In ActiveExplorer.Selection
  If objItem.MessageClass = "IPM.Note" Then
    Set oMail = objItem
   
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "ddmmyyyy", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
     
  sPath = StrFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
 
  End If
  Next
 
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
    BrowseForFolder = False
End Function
 
Invalid:
 BrowseForFolder = False
End Function

---

Hi everyone
The below code does not run in Outlook 2019. Macro settings set to accept digital signed macros. Digital Certificate can be found under email trusted publishers. The code below do run on my other pc and laptop with Outlook 2021. I have run mmc, Thx to Graham Mayor. VBA references are the same on all 3 Computers.

Code:

---

Private WithEvents objSentItems As Items

Private Sub Application_Startup()
Dim objSent As Outlook.MAPIFolder
Set objNS = Application.GetNamespace("MAPI")
Set objSentItems = objNS.GetDefaultFolder(olFolderSentMail).Items
Set objNS = Nothing
End Sub
 
Private Sub objSentItems_ItemAdd(ByVal oMail As Object)

 Dim sPath As String
  Dim dtDate As Date
  Dim sName As String
  Dim StrFolderpath As String
  Dim StrUserPath As Variant

'Defaults to Documents folder
If oMail.MessageClass = "IPM.Note" Then
StrUserPath ="\\JK_Server-PC\Users\JK_Server\My Documents\JKBrokers\Clients\"
StrFolderpath = BrowseForFolder(StrUserPath)

If StrFolderpath = "False" Then
      Cancel = True
      Exit Sub
  End If
 
  sName = oMail.Subject
  ReplaceCharsForFileName sName, "-"
 
  dtDate = oMail.ReceivedTime
  sName = Format(dtDate, "ddmmyyyy", vbUseSystemDayOfWeek, _
    vbUseSystem) & Format(dtDate, "-hhnnss", _
    vbUseSystemDayOfWeek, vbUseSystem) & "-" & sName & ".msg"
   
  sPath = StrFolderpath & "\"
  Debug.Print sPath & sName
  oMail.SaveAs sPath & sName, olMSG
 
  End If
 
End Sub

Private Sub ReplaceCharsForFileName(sName As String, _
  sChr As String _
)
  sName = Replace(sName, "'", sChr)
  sName = Replace(sName, "*", sChr)
  sName = Replace(sName, "/", sChr)
  sName = Replace(sName, "\", sChr)
  sName = Replace(sName, ":", sChr)
  sName = Replace(sName, "?", sChr)
  sName = Replace(sName, Chr(34), sChr)
  sName = Replace(sName, "<", sChr)
  sName = Replace(sName, ">", sChr)
  sName = Replace(sName, "|", sChr)
End Sub

Function BrowseForFolder(Optional OpenAt As Variant) As Variant
  Dim ShellApp As Object
  Set ShellApp = CreateObject("Shell.Application"). _
 BrowseForFolder(0, "Please choose a folder", 0, OpenAt)
 
 On Error Resume Next
    BrowseForFolder = ShellApp.self.Path
 On Error GoTo 0
 
 Set ShellApp = Nothing
    Select Case Mid(BrowseForFolder, 2, 1)
        Case Is = ":"
            If Left(BrowseForFolder, 1) = ":" Then GoTo Invalid
        Case Is = "\"
            If Not Left(BrowseForFolder, 1) = "\" Then GoTo Invalid
        Case Else
            GoTo Invalid
    End Select
 Exit Function
 
Invalid:
    BrowseForFolder = False
End Function

---

Have you tried debugging and stepping through the code on the PC that has Outlook 2019? It might be as simple as a method or object was changed in Outlook 2021.

Yes, I did and there is no errors

Ok I run Outlook 2019 in safe mode (Outlook.exe /safe)
I then run Debug to cursor and get the following File Picker Dialog called Capture instead of the Correct Dialog (please see attachments). This happens in safe mode. In normal mode no popup dialog