Outlook 2019 - VBA code not running

[JOHANKOTZE]

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.



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

[JOHANKOTZE]

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.



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

[jdelano]

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.

[JOHANKOTZE]

Yes, I did and there is no errors

[JOHANKOTZE]

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