Vba İle Mail Gönderimi

30/06/2022, 16:08

sipuasfaf

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
30/06/2022, 18:26

atoykan

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