foutmelding bij verzenden mail mbv CDO

[Andre175]

goedemorgen

met onderstaande code moet het mogelijk zijn om vanuit excel te kunnen mailen.
Echter krijg ik na ongeveer 30 seconden een foutmelding: De transportfunctie kan geen verbinding maken met de server.

Klik ik bij de foutmelding op help, dan wordt deze info weergegeven:

https://docs.microsoft.com/nl-nl/office/vba/language/reference/user-interface-help/automation-error-error-440?f1url=https%3A%2F%2Fmsdn.microsoft.com%2Fquery%2Fdev11.query%3FappId%3DDev11IDEF1%26l%3Dnl-NL%26k%3Dk(vblr6.chm1000440)%3Bk(TargetFrameworkMoniker-Office.Version%3Dv16)%26rd%3Dtrue

Private Sub CommandButton2_Click()
    Dim iMsg As Object
    Dim iConf As Object
    Dim strbody As String
    Dim Flds As Variant

    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")

        iConf.Load -1    ' CDO Source Defaults
        Set Flds = iConf.Fields
        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.strato.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
            .Update
        End With

    strbody = "Hi there" & vbNewLine & vbNewLine & _
        "This is line 1" & vbNewLine & _
        "This is line 2" & vbNewLine & _
        "This is line 3" & vbNewLine & _
        "This is line 4"

    With iMsg
        Set .Configuration = iConf
        .To = "<ontvanger@test.nl>"
        .CC = ""
        .BCC = ""
        .From = """Andre"" <afzender@test.nl>"
        .Subject = "Important message"
        .TextBody = strbody
        .Send
    End With

    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub

Moet ik misschien een invoegtoeppasing (AddIn) in Excel toevoegen?


André

 

[edmoor]

Je geeft geen gebruikersnaam en wachtwoord mee.
Ook moet je volgens mij voor Strato aangeven dat TLS moet worden gebruikt.

 

[Andre175]

        With Flds
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.strato.com"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
            
            
            .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "*****@******.nl"
            .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "(*********)"
            .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
            .Update
        End With

Zo krijg ik iig wel verbinding, echter de foutmelding dat strato deze gebruiker geen toegang geeft.
Nu heb ik ergens gelezen dat wanneer je een GMail-account gebruikt, je in de instellingen van GMail moet aangeven dat gebruik van minder veilige toepassingen is toegestaan.
Is zoiets ook van toepassing bij strato?

 

[edmoor]

Ik ken Strato niet dus daar kan ik geen antwoord op geven.
Bel de helpdesk van Strato eens.

Maar gebruik ook dit eens voor je dat doet:
.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1

 

[Andre175]

Dan komt een andere foutmelding:

Het pad van de directory voor het ophalen is verplicht, maar is niet opgegeven.

ik zal Strato straks ff bellen....

 

[edmoor]

Dus die laatste niet gebruiken en Strato bellen.

 

[Andre175]

is dit van toepassing?

 

[edmoor]

Nee, dat heeft niets met SMTP te maken.

 

[Andre175]

Heel fijn...Strato geeft aan dat het gewoon mogelijk moet zijn, geeft echter geen ondersteuning voor VBA.
Als er iemand nog suggesties heeft?

Wel vond ik op een duits forum ook iets wat op mijn probleem lijkt. Daar was de oplossing Hoofdletters en kleine letters.
Dit heb ik gecontroleerd, mijn adres staat gewoon met kleine letters geregistreerd bij strato.

HIER een link naar het duitse forum.

 

[Andre175]

Net ook met mijn gmail mailadres geprobeerd.
krijg dezelfde foutmelding: 530 5.7.0 user not authenticated

De fout toch in de code? weet het ff niet meer

 

[edmoor]

Zelf gebruik ik dit en werkt prima:
Bekijk bijlage CDO Mail.xlsm

Bij Gmail moet je wel eerst het gebruik van minder veilige apps toestaan:
https://support.google.com/a/answer/6260879?hl=nl

 

[Andre175]

Die had ik net gevond Edmoor...
maar ook die krijg ik niet draaiende...

 

[edmoor]

Hij werkt bij mij prima met zowel GMAIL als Office365.
Dan zou ik het zo ook niet weten helaas.

 

[Andre175]

Morgenavond thuis maar ff proberen op mijn desktop thuis....
zit nu in België... mobiel

 

[Andre175]

Hey Edmoor,

Op 1 of andere manier stond het gebruik van minder veilige apps weer uit bij de instellingen van gmail...
Deze dus weer aan gezet, en ja hoor, verzenden met gmail werkt.

toen in jou bestand de gegevens van strato ingevuld, en wat denk je.... het werkt gewoon
Ik zal de codes eens naast elkaar leggen en kijken wat de verschillen zijn, dan moet de code die ik heb ook gewoon werkend te krijgen zijn.

 

[edmoor]

Je hebt in ieder geval een mooi compleet voorbeeld zo

 

[Andre175]

yup.... mijn hartelijk dank daarvoor.:thumb:

dit gaat helemaal goed komen

 

[Andre175]

Mag ik je nog 1 ding vragen Edmoor?

            msgTekst = TextBox3.Value & (" ") & LiB_adres.List(j - 1, 2)

In textbox3 staat de aanhef, en in de listbox de naam van de betreffende persoon.
In textbox4 staat het complete bericht (Multiline=true).

het complete bericht wil ik er graag bij onder hebben, tussen de aanhef met naam en het bericht 2 lege regels.
Hoe gaat dit in zijn werk?

 

[Andre175]

oeps.... te snel gevraagd....

            msgTekst = TextBox3.Value & (" ") & LiB_adres.List(j - 1, 2) & vbCrLf & vbCrLf & Textbox4

vraagstukken opgelost.

 

[Andre175]

goedemiddag.

ik heb nu de boel draaiende... met dank aan Edmoor. (De code die ik had nog niet uitgeplozen.. )

Kan de code nog uitgebreid worden zodat de verzonden mails ook in de map Sent Items komen?

Private Sub CommandButton2_Click()
    Dim iMsg As Object
    Dim iConf As Object
    Dim Flds As Variant
    Dim Schema As String

    Dim SMTPsendusing As Integer
    Dim SMTPauthenticate As Integer
    Dim SMTPserver As String
    Dim SMTPserverport As Integer
    Dim SMTPusessl As Boolean
    Dim SMTPusername As String
    Dim SMTPpassword As String
    Dim SMTPconnectiontimeout As Integer
    
    Dim msgTO As String
    Dim msgOnderwerp As String
    Dim msgTekst As Variant
    Dim msgBijlage As Variant
    
    If TextBox2.Value = vbNullString Or TextBox3 = vbNullString Then
        MsgBox "Vul alle gegevens in", vbInformation, "Onderwerp/Aanhef."
        Exit Sub
    End If
    
    If TB_Body.Value = "" Then
        Select Case MsgBox("Mail versturen zonder tekst?", vbYesNo, "Let op!")
            Case vbYes
            Case vbNo
                Exit Sub
        End Select
    End If
    
    For j = 1 To 8
        If Me("CheckBox" & j) = True Then i = Me("CheckBox" & j).Caption Else
    Next j
        
    Select Case MsgBox("Adressen gefilterd op " & i & ", " & LiB_adres.ListCount & " mails versturen?", vbYesNo, "Zeker weten?.")
        Case vbYes
        Case vbNo
            Exit Sub
    End Select
    
    SMTPsendusing = Range("SMTPtype")
    SMTPauthenticate = Range("SMTPauthenticate")
    SMTPserver = Range("SMTPserver")
    SMTPserverport = Range("SMTPport")
    SMTPusessl = Range("SMTPusessl")
    SMTPusername = Range("SMTPusername")
    SMTPpassword = Range("SMTPpassword")
    SMTPconnectiontimeout = Range("SMTPtimeout")
    
    Set iMsg = CreateObject("CDO.Message")
    Set iConf = CreateObject("CDO.Configuration")
    
    Schema = "http://schemas.microsoft.com/cdo/configuration/"
    iConf.Load -1                                               'zet CDO standaard instellingen
    Set Flds = iConf.Fields
    With Flds
        .Item(Schema & "sendusing") = SMTPsendusing
        .Item(Schema & "smtpauthenticate") = SMTPauthenticate
        .Item(Schema & "smtpserver") = SMTPserver
        .Item(Schema & "smtpserverport") = SMTPserverport       'Niet gebruiken bij Office365 SMTP
        .Item(Schema & "smtpusessl") = SMTPusessl
        .Item(Schema & "sendusername") = SMTPusername
        .Item(Schema & "sendpassword") = SMTPpassword
        .Item(Schema & "smtpconnectiontimeout") = SMTPconnectiontimeout
        .Update
    End With
            
            For jj = 1 To Lib_Bijlage.ListCount                 'Bijlage bijvoegen
                msgBijlage = Lib_Bijlage.List(jj - 1, 0)
                iMsg.AddAttachment msgBijlage
            Next jj
            
    i = LiB_adres.ListCount                                     'Ontvanger(s) bepalen
        For j = 1 To i
            msgTO = LiB_adres.List(j - 1, 5)
            msgOnderwerp = TextBox2.Value
            msgTekst = TextBox3.Value & (" ") & LiB_adres.List(j - 1, 2) & vbCrLf & vbCrLf & TB_Body

            With iMsg
                Set .Configuration = iConf
                .To = msgTO
                If msgTO = "" Then GoTo fout:
                .BCC = ""
                .From = SMTPusername
                .Subject = msgOnderwerp
                .TextBody = msgTekst
                .Send
            End With
            If Err.Number <> 0 Then
fout:
                MsgBox "Mail naar " & LiB_adres.List(j - 1, 1) & ", contactpersoon/naam " & LiB_adres.List(j - 1, 2) & " is niet goed gegaan.", vbInformation, "LET OP!!"
            End If
        Next j

    If Err.Number = 0 Then
        MsgBox "De mail(s) zijn onderweg", vbInformation, "Even geduld A.U.B."
    End If
        
    Set iMsg = Nothing
    Set iConf = Nothing
    Set Flds = Nothing
End Sub