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 = "[email protected]" 'kendi email adresiniz
recipient = "[email protected]" '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