VBA - Can anyone please tell me where to look or what am I doing wrong? Thank you very much!

Ricardo E. Vélez Pérez 21 Reputation points
2021-02-19T11:51:32.3+00:00

Sending emails from Excel installed on my machine using Outlook 365 web version. This worked until the company implemented the Microsoft 365 Authenticator. Since then it stops at ".send"
Sub Enviar()
Dim EmailMsg, EmailConf As Object, EmailFields As Variant, sh As Worksheet
Dim Subj, Mess, LastName, FirstName, Team, GameDate, GameTime, GameLocation, Field, Email, Attach As String
Dim ContactRow, LastRow, SentCounter As Long, EmailUsr As String
'
EmailUsr = "JuanDelPueblo@nomail.com"
Set sh = Sheets("Envio")
For ContactRow = 2 To 3
If sh.Range("A" & ContactRow).Value <> Empty Then
'
Set EmailMsg = CreateObject("CDO.Message") 'CDO (Collaboration Data Objects) -Make sure you have the 'CDO For Windows' Library Selected
Set EmailConf = CreateObject("CDO.Configuration")
EmailConf.Load -1 ' Set CDO Source Defaults
Set EmailFields = EmailConf.Fields
With EmailFields
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Item("http://schemas.microsoft.com/cdo/configuration/sendtls") = True
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1 'cdoBasic
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.office365.com"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 25
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2 'cdoSendUsingPort
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = EmailUsr
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "EntrarPassword"
.Update
End With
'
Email = sh.Range("A" & ContactRow).Value 'In column M you must have the email of each record.
Nombrecompleto = sh.Range("B" & ContactRow).Value
Nombre = sh.Range("C" & ContactRow).Value
Apellido = sh.Range("D" & ContactRow).Value
Nombreapellido = sh.Range("E" & ContactRow).Value
Vacaciones = sh.Range("F" & ContactRow).Value
Enfermedad = sh.Range("G" & ContactRow).Value
Mes = sh.Range("H" & ContactRow).Value
Ano = sh.Range("I" & ContactRow).Value
Vacacionesc = sh.Range("J" & ContactRow).Value
Enfermedadc = sh.Range("K" & ContactRow).Value
Vacacionesd = sh.Range("L" & ContactRow).Value
Enfermedadd = sh.Range("M" & ContactRow).Value
Vacacionescd = sh.Range("N" & ContactRow).Value
Enfermedadcd = sh.Range("O" & ContactRow).Value
Subj = "Prueba de envio de Balance Vacaciones y Enfermedad: " & Mes & " " & Ano & " " & Nombrecompleto
Msg = "NOTA: Esto es una prueba de envio multiple, favor no hacer caso del mismo, pueden borrarlo" & vbNewLine
Msg = vbNewLine & "Saludos " & Nombre & " " & Apellido & "," & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & "Incluyo el balance en horas al cierre del mes de " & Mes & " de " & Ano & vbNewLine
Msg = Msg & " Horas / días disponibles de Vacaciones: " & Vacaciones & " / " & Vacacionesd & vbNewLine
Msg = Msg & " Horas / días disponibles de Enfermedad: " & Enfermedad & " / " & Enfermedadd & vbNewLine & vbNewLine
Msg = Msg & "Horas utilizadas en el mes de " & Mes & " de " & Ano & vbNewLine
Msg = Msg & " Horas / días de Vacaciones: " & Vacacionesc & " / " & Vacacionescd & vbNewLine
Msg = Msg & " Horas / días de Enfermedad: " & Enfermedadc & " / " & Enfermedadcd & vbNewLine & vbNewLine & vbNewLine
Msg = Msg & "Quedo a sus órdenes para aclarar cualquier duda o pregunta que pueda surgir," & vbNewLine & vbNewLine
Msg = Msg & "Juan Del Pueblo" & vbNewLine
Msg = Msg & "HR & Customer Service" & vbNewLine
Msg = Msg & "P: 787.999.999 [268]" & vbNewLine
Msg = Msg & "JuanDelPueblo@nomail.com"
'
With EmailMsg
Set .Configuration = EmailConf
.To = Email
.CC = ""
.BCC = ""
.From = EmailUsr
.Subject = Subj
If Attach <> Empty Then .AddAttachment Attach
.TextBody = Msg
On Error Resume Next
.Send 'this is where it stops
On Error GoTo 0
End With
If Err.Number = 0 Then
SentCounter = SentCounter + 1
End If
End If
Set EmailMsg = Nothing
Set EmailConf = Nothing
Set EmailFields = Nothing
Next ContactRow
MsgBox SentCounter & " Emails have been sent"
End Sub

Outlook Management
Outlook Management
Outlook: A family of Microsoft email and calendar products.Management: The act or process of organizing, handling, directing or controlling something.
4,875 questions
Excel Management
Excel Management
Excel: A family of Microsoft spreadsheet software with tools for analyzing, charting, and communicating data.Management: The act or process of organizing, handling, directing or controlling something.
1,638 questions
0 comments No comments
{count} votes

Accepted answer
  1. Tom van Stiphout 1,621 Reputation points MVP
    2021-02-19T20:09:18.327+00:00

    CDO is more than 20 years old. AFAIK it does not support TLS 1.2 or better which is rapidly becoming the standard. You will need to find a more modern way to send emails.
    https://learn.microsoft.com/en-us/microsoft-365/compliance/prepare-tls-1.2-in-office-365?view=o365-worldwide

    1 person found this answer helpful.

1 additional answer

Sort by: Most helpful
  1. Ricardo E. Vélez Pérez 21 Reputation points
    2021-02-20T22:38:31.247+00:00

    Thanks a lot! I will verify the document to which you refer.

    0 comments No comments