KEP TE TOPLU MAİL GÖNDERME

[erbilnal]

Arkadaşlar selam, toplu mail atma excel var, kep adresine uyarlayıp kep ten toplu mail atmaya çevirebilirmiyim? ya da karşılaşan deneyen oldumu?

 

[htsumer]

Bir dene biraz meşaketli

Sub TopluKEPMailGonder()
    Dim CDO_Mail As Object
    Dim CDO_Config As Object
    Dim i As Long
    Dim SonSatir As Long
    Dim ws As Worksheet
    
    ' Aktif sayfayı ayarla
    Set ws = ThisWorkbook.Sheets("Sheet1") ' Adını değiştir
    
    ' Son satırı bul
    SonSatir = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row ' A sütunu KEP adresi
    
    ' CDO ayarları (KEP SMTP)
    Set CDO_Config = CreateObject("CDO.Configuration")
    With CDO_Config.Fields
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.kep.com.tr" ' KEP SMTP sunucusu
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465 ' veya 587
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
        .Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = "kullanici@kep.com.tr"
        .Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = "sifre"
        .Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
        .Update
    End With
    
    ' Döngü ile listeyi oku ve mail gönder
    For i = 2 To SonSatir ' Başlık varsa 2'den başla
        If ws.Cells(i, "A").Value <> "" Then
            Set CDO_Mail = CreateObject("CDO.Message")
            Set CDO_Mail.Configuration = CDO_Config
            
            With CDO_Mail
                .To = ws.Cells(i, "A").Value ' KEP alıcı
                .From = "gonderen@kep.com.tr" ' Senin KEP adresin
                .Subject = ws.Cells(i, "B").Value ' Konu (B sütunu)
                .TextBody = ws.Cells(i, "C").Value ' Mesaj içeriği (C sütunu)
                
                ' Eklemek istersen:
                ' .AddAttachment ws.Cells(i, "D").Value ' D sütununda dosya yolu
                
                On Error Resume Next
                .Send
                On Error GoTo 0
            End With
            
            ' Temizlik
            Set CDO_Mail = Nothing
        End If
    Next i
    
    MsgBox "Tüm KEP mailleri gönderildi!", vbInformation
End Sub