Error in SendOutlookMessage 429 - ActiveX Component Can't Create Object

Instalei o Windows 10 Pro versão 1511 e algumas das minhas aplicações deixaram de funcionar, mais concretamente todas aquelas que enviam por mail documentos anexados.
Já pesquisei na net e não consigo voltar a por o ´módulo a funcionar.
A mensagem de erro é: Error in SendOutlookMessage 429 - ActiveX Component Can't Create Object
Já fiz restart á máquina várias vezes
Tentei com o Outlook ligado e desligado como descrito em vários artigos
Já retirei do MSACCESS a referência à biblioteca MSOUTL.OLB e tornei a incluir a referência à biblioteca
Já confirmei a biblioteca MSOUTL.OLB na máquina de uma amiga. Tem a mesma data e o mesmo tamanho.

A versão do meu Access é Microsoft Office Professional Plus 2010 versão 14.0.4763.1000 e o Outlook 2010 versão 14.0.0.6117

O código é o seguinte:

Option Compare Database
Option Explicit
Public Function SendOutlookMessage( _
   strEmailAddress As String, _
   strEmailCCAddress As String, _
   strEmailBccAddress As String, _
   strSubject As String, _
   strMessage As String, _
   blnDisplayMessage As Boolean, _
   Optional strAttachmentFullPath As String)
   
'* Copy this code and paste it into a new Access
'* Module. Click Tools > References and make sure
'* that "Microsoft Office Outlook x.0 Object Library"
'* is checked. Neste caso a versão 14
'*
'* This subroutine sends an e-mail message through
'* MS Outlook. If the "blnDisplayMessage" parm is
'* set to "False", the message is placed in the
'* Outlook Outbox. "True" displays the message, and
'* user will have to click "Send" to send it.
'*
'* Ex.:
'*
'* SendOutlookMessage _
'*      "john@doe.com", _
'*      "ccJane@doe.com", _
'*      "bccSue@doe.com", _
'*      "Subject", _
'*      "Body of Message", _
'*      False, _
'*      "C:\My Documents\MyAttachmentFile.txt"
   
Dim objApp As Outlook.Application
Dim objOutlookMsg As Outlook.MailItem
Dim objOutlookRecipient As Outlook.Recipient
Dim objOutlookAttach As Outlook.Attachment
Dim blnOutlookInitiallyOpen As Boolean
Dim strProcName As String

On Error Resume Next
strProcName = "SendOutlookMessage"

'Adicionei esta linha
DoCmd.SetWarnings False

blnOutlookInitiallyOpen = True
Set objApp = GetObject(, "Outlook.Application.14")
If objApp Is Nothing Then
   Set objApp = CreateObject("Outlook.Application.14")
   '* Outlook wasn't open when this function started.
   blnOutlookInitiallyOpen = False
End If
If Err <> 0 Then Beep: _
   MsgBox "The code failed at line " & Erl() & vbCrLf & "Error in " & strProcName & " (1): " _
       & Err.Number & " - " & Err.Description: _
   Err.Clear: _
   GoTo Exit_Section

'Create the message
Set objOutlookMsg = objApp.CreateItem(olMailItem)
If Err <> 0 Then Beep: _
   MsgBox "Error in " & strProcName & " (2): " _
       & Err.Number & " - " & Err.Description: _
   Err.Clear: _
   GoTo Exit_Section

'strMessage = "Enquiry No: " & StrEnquiryNo & vbCrLf & _
'strSubject = "Enquiry No: " & StrEnquiryNo & vbCrLf & _

With objOutlookMsg
   Set objOutlookRecipient = .Recipients.Add(strEmailAddress)
   objOutlookRecipient.Type = olTo
   If strEmailCCAddress = "" Then
   Else
       Set objOutlookRecipient = .Recipients.Add(strEmailCCAddress)
       objOutlookRecipient.Type = olCC
   End If
   If strEmailBccAddress = "" Then
   Else
       Set objOutlookRecipient = .Recipients.Add(strEmailBccAddress)
       objOutlookRecipient.Type = olBCC
   End If
   .Subject = strSubject
   .Body = strMessage

   '* Add attachments
   If Not IsMissing(strAttachmentFullPath) Then
       If Trim(strAttachmentFullPath) = "" Then
       Else
           Set objOutlookAttach = .Attachments.Add(strAttachmentFullPath)
           If Err <> 0 Then Beep: _
               MsgBox "Error in " & strProcName & " (3): " _
                   & Err.Number & " - " & Err.Description: _
               Err.Clear: _
               GoTo Exit_Section
       End If
   End If

   If blnDisplayMessage Then
       .Display
   Else
       '* Send message by putting it in the Outbox
       .Send
   End If
End With
   
DoCmd.SetWarnings True
   
If Err <> 0 Then Beep: _
   MsgBox "Error in " & strProcName & " (99): " _
       & Err.Number & " - " & Err.Description: _
   Err.Clear: _
   GoTo Exit_Section
   
Exit_Section:
   On Error Resume Next
   If Not blnOutlookInitiallyOpen Then
      objApp.Quit
   End If
   Set objApp = Nothing
   Set objOutlookMsg = Nothing
   Set objOutlookAttach = Nothing
   Set objOutlookRecipient = Nothing
   On Error GoTo 0
   DoCmd.SetWarnings True
   End Function

Este código funcionava perfeitamente em Windows 7 com a mesma versão do Office pelo que presumo que seja problema Windows 10.

Alguém que tenha tido o mesmo problema me poderia ajudar.

Antecipadamente grato,

Bartolomeu Silva

Bom dia Bartolomeu Silva, Eu utilizo o Windows 7, mais quem sabe o meu código não funcione em sua maquina.

Código:

    Dim opcao As Integer
            Dim Out As Outlook.Application
            Dim NS As Outlook.Namespace
            Dim Folder As MAPIFolder
            Dim Mens As MailItem
            Dim objOutlookRec As Outlook.Recipient
                        
            Set Out = New Outlook.Application
            Set NS = Out.GetNamespace("MAPI")
            Set Folder = NS.GetDefaultFolder(olFolderInbox)
            Set Mens = Folder.Items.Add
                        
            With Mens
            Set objOutlookRec = .Recipients.Add(“ ”) ‘Destinatario
            .CC = " " 'Destinatário com cópia
            .BCC = " " 'Destinatário com cópia oculta
            .Body = “ “ ‘Texto do corpo do e-mail

            .Subject = " ” ‘Assunto do E-mail
            .Attachments.Add “ “ ‘ Caminho e extensão do arquivo  Exp: \C:\Arquivo.pdf
            .Display ‘ Display para abrir o e-mail antes do envio ou Send para envio direto
            End With
         End If


Espero te lhe ajudado.  

Boa tarde BigFill

Testei o teu código e não funciona na minha máquina.
O problema é sem dúvida do Windows 10.

A solução apontada pela própria Microsoft será reinstalar o office 2010 o que fiz e continua a dar erro.

Obrigado pelo seu tempo e por tentado ajudar

Um abraço