Vba İle Mail Gönderimi

Merhaba Arkadaşlar,
Uzun süredir CDO ile Vba üzerinden gmail kullanarak mail gönderebiliyorduk. Google bey amca daha az güvenli uygulamaların erişimini kapattığı için artık mail gönderimi yapamıyorum. Çözüm için araştırdım fakat somut bir çözüm bulamadım. Yardımcı olabilir misiniz acaba?? 

Function SendMail()

    On Error Resume Next

    Dim iMsg, iConf, Flds, schema, rapor

    Set iMsg = CreateObject("CDO.Message")

    Set iConf = CreateObject("CDO.Configuration")

    Set Flds = iConf.Fields

    schema = "http://schemas.microsoft.com/cdo/configuration/"

    Flds.Item(schema & "sendusing") = 2

    Flds.Item(schema & "smtpserver") = xxxx

    Flds.Item(schema & "smtpserverport") = xxxx

    Flds.Item(schema & "smtpauthenticate") = xxxx

    Flds.Item(schema & "sendusername") = "xxxxxx"

    Flds.Item(schema & "sendpassword") = "xxxxxxxx"

    Flds.Item(schema & "smtpusessl") = xxxx

    Flds.Update



    With iMsg

        .To = xxxx

        .From = xxxx

        .Subject = xxxx

        .HTMLBody = xxxx

        .Sender = "System"

        '.Organization = xxxx

        '.ReplyTo = xxxx



        Set .Configuration = iConf

        .Send



    End With



    Set iMsg = Nothing

    Set iConf = Nothing

    Set Flds = Nothing

End Function

Bu makaleyi inceleyin.

Bu çerçevede aşağıdaki kodları kullanın.

 Dim from, recipient, cc, bcc, password, subject, body, attachment As String, enable_html As Boolean

   

      from = "x@x.com" 'kendi email adresiniz

    recipient = "y@y.com" 'alıcı email adresi

    'cc = "" 'CC email alıcısı (istiyorsanız opsiyoneldir açıklamadan koda dönüştürün)

    'bcc = "" 'BCC email alıcısı (istiyorsanız opsiyoneldir açıklamadan koda dönüştürün)

    password = "app password" 'Gmail App passwordünüzü girin (2 faktorlü doğrulama etkinleştirme makalesindeki authentication kodu)

    subject = "xxx" 'Email konunuz

    body = "yyy" 'Mesajınız

    'attachment = "" 'eklerinizin yolu (istiyorsanız opsiyoneldir açıklamadan koda dönüştürün)

    'enable_html = False 'Mailinizin Html formatlı olmasını istiyorsanız True yapın (istiyorsanız opsiyoneldir açıklamadan koda dönüştürün)

    

    'buradan itibaren bir değişiklik yapmanız gerekmemektedir

    On Error GoTo Err

    Dim mailObj As Object

    Dim configObj As Object

    Dim fields As Variant

    Dim msConfigURL As String



    msConfigURL = "http://schemas.microsoft.com/cdo/configuration"



    Set mailObj = CreateObject("CDO.Message")

    Set configObj = CreateObject("CDO.Configuration")

    configObj.Load -1

    Set fields = configObj.fields

    With mailObj

        .subject = subject

        .from = from

        .to = recipient

        .cc = cc

        .bcc = bcc

        .Addattachment attachment

    End With



    If enable_html = True Then

        With mailObj

            .htmlbody = body

        End With

    Else

        With mailObj

            .textbody = body

        End With

    End If



    With fields

        'Enable SSL Authentication

        .Item(msConfigURL & "/smtpusessl") = True

        'Enable MTP authentication

        .Item(msConfigURL & "/smtpauthenticate") = 1

        'Set the SMTP server and port Details

        .Item(msConfigURL & "/smtpserver") = "smtp.gmail.com"

        .Item(msConfigURL & "/smtpserverport") = 465

        .Item(msConfigURL & "/sendusing") = 2

        .Item(msConfigURL & "/sendusername") = from

        .Item(msConfigURL & "/sendpassword") = password

        .Update

    End With



    mailObj.Configuration = configObj

    mailObj.Send



    Set mailObj = Nothing

    Set configObj = Nothing



    Exit Sub



    Exit_Err:

    Set mailObj = Nothing

    Set configObj = Nothing

    End



    Err:

    Select Case Err.Number

        Case -2147220973

            MsgBox "Error: İnternet bağlantınızı kontrol edin." & vbNewLine & Err.Number & ": " & Err.Description

        Case -2147220975

            MsgBox "Error: Adreslerinizi kontrol edin." & vbNewLine & Err.Number & ": " & Err.Description

        Case Else

            MsgBox "Bir hata oluştu." & vbNewLine & Err.Number & ": " & Err.Description

    End Select



    Resume Exit_Err



    End Sub