Consulting

Results 1 to 5 of 5

Thread: Outlook 2019 - VBA code not running

  1. #1

    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.

    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
    Last edited by JOHANKOTZE; 09-01-2024 at 01:13 PM. Reason: Code

  2. #2

    Outlook 2019 - VBA code not running

    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

  3. #3
    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.

  4. #4
    Yes, I did and there is no errors

  5. #5
    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
    Attached Images Attached Images

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •