Error 48389 con MapSess con nuevo Outlook 365

[EmilioRL]

Buena tarde Estimados:
Alguien ha tenido un problema similar al mio, teniamos instalado Office 2007 y nuestro envío de correos con MapSess se ejecutaba sin problema, ahora que se instalo office 365 nos emite el error: Error no 48389 (sin mas referencia), mi código desarrollado en Visual Basic 6 es el siguiente:

Public Sub EnviarCorreos(StrSubject As String, StrMensaje As String)
On Error GoTo Errores
Dim Conta As Integer
Dim DatCorreosRequerimientos As ADODB.Recordset

Me.MAPSess.NewSession = False
Me.MAPSess.SignOn
Me.MAPMess.SessionID = Me.MAPSess.SessionID
Me.MAPMess.Compose
Me.MAPMess.MsgSubject = StrSubject
Me.MAPMess.MsgNoteText = StrMensaje

'Me.MAPSess.NewSession = False
Me.MAPSess.DownLoadMail = False
Me.MAPSess.LogonUI = True
Me.MAPSess.SignOn
Me.MAPSess.NewSession = True
Me.MAPMess.SessionID = Me.MAPSess.SessionID
Me.MAPMess.Compose
Me.MAPMess.MsgSubject = StrSubject
Me.MAPMess.MsgNoteText = StrMensaje

Q = "SELECT * FROM GEN_CORREOS_USUARIOS "  'Usuarios a enviar
       
Select Case AbrirRs(Conexion, DatCorreosRequerimientos, Q)
    Case VRecordset_OK
        Conta = 0
        While Not DatCorreosRequerimientos.EOF
            Me.MAPMess.RecipIndex = Conta
            Me.MAPMess.RecipAddress = "smtp: " & DatCorreosRequerimientos!EMAIL
            Me.MAPMess.RecipDisplayName = "smtp: " & DatCorreosRequerimientos!EMAIL
            Me.MAPMess.RecipType = mapToList
            Me.MAPMess.AddressResolveUI = True
            Conta = Conta + 1
            DatCorreosRequerimientos.MoveNext
        Wend
        DatCorreosRequerimientos.Close
    Case VRecordset_Vacio
        MsgBox "NO HAY REGISTROS PARA ENVIAR CORREOS EN GEN_CORREOS_USUARIOS", vbCritical, "ERROR"
        DatCorreosRequerimientos.Close
    Case VRecordset_Error
        MsgBox "Hubo un error al abrir GEN_CORREOS_USUARIOS en EnviarCorreos: " & Err.Description, vbCritical, "ERROR"
End Select
Set DatCorreosRequerimientos = Nothing
       
Me.MAPMess.AddressResolveUI = False
Me.MAPMess.Send False
Me.MAPSess.SignOff 'Se cierra la conexion

Exit Sub
Errores:
    Set DatCorreosRequerimientos = Nothing
    MsgBox "Hubo un error en EnviarCorreos en Modulo General, Error No. " & Err.Number & " " & Err.Description, vbCritical + vbOKOnly
End Sub

El error me da en la linea Me.MAPSess.SignOn

Sera que tengo que cambiar algo en el codigo?

De antemano muchas gracias por la ayuda que me puedan brindar, saludos,

Emilio R.

[Nocturno]

A mí me pasaba algo parecido desde Excel VBA y era un tema de permisos.
Echa un vistazo aquí:
https://support.microsoft.com/es-es/topic/c%C3%B3mo-trabajar-con-la-actualizaci%C3%B3n-de-seguridad-para-correo-electr%C3%B3nico-de-outlook-en-una-base-de-datos-de-access-e43a0596-354f-5fde-b9ba-b3096bcca733

[VisualMas]

Buenos días.

Perdonar, me ocurre lo mismo y no consigo resolverlo. ¿Podéis ayudarme?

Mi código:
         If frmPrincipal.MiSesion.SessionID = 0 Then frmPrincipal.MiSesion.SignOn
                frmPrincipal.MiMensaje.SessionID = frmPrincipal.MiSesion.SessionID
                frmPrincipal.MiMensaje.Compose
                vEMail = Trim(rs!Email)
                I = frmPrincipal.MiMensaje.RecipCount
                Do
                    frmPrincipal.MiMensaje.RecipIndex = I
                    frmPrincipal.MiMensaje.RecipType = 1
                    If InStr(vEMail, ";") > 0 Then
                        frmPrincipal.MiMensaje.RecipAddress = Trim(Left(vEMail, InStr(vEMail, ";") - 1))
                        vEMail = Trim(Right(vEMail, Len(vEMail) - InStr(vEMail, ";")))
                    Else
                        frmPrincipal.MiMensaje.RecipAddress = Trim(vEMail)
                        vEMail = ""
                    End If
                    frmPrincipal.MiMensaje.AddressResolveUI = False
                    frmPrincipal.MiMensaje.ResolveName
                    I = I + 1
                Loop Until (vEMail = "")
                frmPrincipal.MiMensaje.MsgSubject = " "
                frmPrincipal.MiMensaje.MsgNoteText = " "
                frmPrincipal.MiMensaje.Send True
            End If
   


El error 48389 lo da en  frmPrincipal.MiSesion.SignOn


Gracias anticipadas!

[VisualMas]

Resuelto!