Skip to main content

AccessTr.neT


Liste Kutusundan Toplu Mail Gönderimi Hakkın

Liste Kutusundan Toplu Mail Gönderimi Hakkın

Çözüldü #1
Merhaba Arkadaşlar,

Liste kutusundan gmail ile toplu mail göndermek istiyorum.
İletilecek mail adreslerini ve mail metnini liste kutusundan,
Gönderilen mail adresini, şifreyi, konuyu metin kutusundan alıyor.
Aşağıdaki kodları denediğimde mail gönderiliyor ancak liste kutusundaki tüm alanlar seçili olmasına rağmen sadece birine gönderiliyor.
Acaba nerede eksiklik var.

Cevabınızı beklerim.

Saygılarımla.



Private Sub Komut13_Click()
If (IsNull(txtgmailadresi)) Or (IsNull(txtgmailsifre)) Or (IsNull(Liste1.Column(3))) Or (IsNull(txtKonu)) Or (IsNull(Liste1.Column(1))) Then
        MsgBox "Tüm alanları eksiksiz olarak doldurmanız gerekmektedir kontrol edip tekrar deneyiniz!! ", vbCritical + vbOKOnly, "Eksik Bırakılan Alan !!!"
        Exit Sub
Else
SendMail
MsgBox "Mailiniz Başarı İle Gönderildi..", vbOKOnly, "Durum Bilgiisi..!!!"
End If
End Sub

Function SendMail()
  Dim iMsg, iConf, Flds, schema
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") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = txtgmailadresi
Flds.Item(schema & "sendpassword") = txtgmailsifre
Flds.Item(schema & "smtpusessl") = 1
Flds.Update



With iMsg
.To = Me.Liste1.Column(3)
.From = txtGonderen & "(" & txtgmailadresi & ")"
.Subject = txtKonu
.HTMLBody = Me.Liste1.Column(1)
.Sender = "xx"
.Organization = txtgmailadresi
.ReplyTo = txtgmailadresi
If IsNull(Me.txteklenti) Or Me.txteklenti = "" Then
Else
    If InStr(1, Me.txteklenti, ",") > 0 Then
        dosya = Split(Me.txteklenti, ",")
        For i = LBound(dosya) To UBound(dosya)
        .AddAttachment dosya(i)
        Next
    Else
        .AddAttachment Me.txteklenti
    End If
    End If
Set .Configuration = iConf
 .send
End With
Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Function
Cevapla
#2
Merhaba,

mail gönderme koduna liste kutusundan veri alması için döngü eklemeniz gerekli. Kodu aşağıdaki ile değiştirerek deneyiniz.


Private Sub Komut13_Click()
If (IsNull(txtgmailadresi)) Or (IsNull(txtgmailsifre)) Or (IsNull(txtKonu)) Then
        MsgBox "Tüm alanları eksiksiz olarak doldurmanız gerekmektedir kontrol edip tekrar deneyiniz!! ", vbCritical + vbOKOnly, "Eksik Bırakılan Alan !!!"
        Exit Sub
Else
SendMail
MsgBox "Mailiniz Başarı İle Gönderildi..", vbOKOnly, "Durum Bilgiisi..!!!"
End If
End Sub

Function SendMail()
  Dim iMsg, iConf, Flds, schema
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") = "smtp.gmail.com"
Flds.Item(schema & "smtpserverport") = 465
Flds.Item(schema & "smtpauthenticate") = 1
Flds.Item(schema & "sendusername") = txtgmailadresi
Flds.Item(schema & "sendpassword") = txtgmailsifre
Flds.Item(schema & "smtpusessl") = 1
Flds.Update

For GSayi = 0 To Me.Liste1.ListCount - 1 'eklenen kod     

With iMsg
.To = Me.Liste1.Column(3, Gsayi)
.From = txtGonderen & "(" & txtgmailadresi & ")"
.Subject = txtKonu
.HTMLBody = Me.Liste1.Column(1, GSayi) 'düzeltilen kod
.Sender = "xx"
.Organization = txtgmailadresi
.ReplyTo = txtgmailadresi
If IsNull(Me.txteklenti) Or Me.txteklenti = "" Then
Else
    If InStr(1, Me.txteklenti, ",") > 0 Then
        dosya = Split(Me.txteklenti, ",")
        For i = LBound(dosya) To UBound(dosya)
        .AddAttachment dosya(i)
        Next
    Else
        .AddAttachment Me.txteklenti
    End If
    End If
Set .Configuration = iConf
 .send
End With

Next 'eklenen kod


Set iMsg = Nothing
Set iConf = Nothing
Set Flds = Nothing
End Function
Cevapla
#3
Teşerkkür ederim Sayın ozanakkaya. Vermiş olduğunuz kod çalışmaktadır.
Cevapla

Bir hesap oluşturun veya yorum yapmak için giriş yapın

Yorum yapmak için üye olmanız gerekiyor

ya da
Task