Skip to main content

AccessTr.neT


Excel Outlook İle Dosya Ekli Toplu Mail Gönderme

Oğuz Türkyılmaz
Oğuz Türkyılmaz
45
3533

Excel Outlook İle Dosya Ekli Toplu Mail Gönderme

Çözüldü #1
Merhaba

Bu kodları internette konuyla alakalı araştırma yaparken buldum fakat uygulama dosyası rar ile açıldığında hasarlı olduğundan kodlarla işleyiş arasında bağlantı kuramadığımdan bu kodları kendi projeme adapte edemedim.

Bu kodları WINPERAX Excel çalışma sayfamın Ana_Sayfa sekmesinde bulunan Mail gönder butonuna basarak masa üstümde yer alan bir PDF dosyasını mail adreslerinin tümüne eklemek ve topluca mail göndermek için nasıl revize etmeliyim. Çok fazla mail adresi olduğunda gönderim esnasında ID numarasına göre başlangıç ve bitiş numaraları vererek sınırlama getirilmiş ve sorun oluşturabilecek bu durum kodda zaten çözülmüş. Ben bu kodları uygulamama nasıl adapte edebilirim. Yardımlarınız için şimdiden teşekkür ederim. Parola : 171717



Sub kod_PDF_mail()

    Klasor = Range("m36")
    On Error Resume Next
    If Dir(Klasor) = "" Then MkDir Klasor

    Dim yol_isim    As String
    Dim kayıt_yeri  As String
    Dim i          As Long
 
    kayıt_yeri = Range("M36")

    basla = InputBox("Başlangınç No")
    If basla = "" Then Exit Sub
    bitis = InputBox("Bitiş No")
    If bitis = "" Then Exit Sub

    If CreateObject("scripting.filesystemobject").folderexists(kayıt_yeri) = False Then _
            CreateObject("scripting.filesystemobject").createfolder (kayıt_yeri)

    For i = basla To bitis

        Range("N11") = i
        If Range("N14") <> "" Then
            yol_isim = Range("M37")

            Sheets("MUTABAKAT FORMU").ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:=yol_isim, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
                 
            With Application
                .EnableEvents = True
            End With
            Dim objOutlook As Object
            Dim objMail As Object
            Dim NoA As Long
            Set objOutlook = CreateObject("Outlook.Application")
            Set objMail = objOutlook.CreateItem(0)
            With objMail
                .To = Range("N21")
                .cC = Range("N20")
                .Subject = Range("M35")
                .body = "Sayın yetkili, Ekte tarafınıza ait mutabakat mektubu bulunmaktadır. En kısa sürede geri dönüşünüzü bekliyoruz. Saygılarımızla,"
                .Attachments.Add yol_isim
                .Importance = 2
                .Save
                .Display
                '.Send ' gönder
                Sheets("Aktif Bayiler").Cells(i + 6, "R") = "Mail gönderildi"
            End With
        End If
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

End Sub

[Resim: do.php?img=10875]
.rar WINPERAX - Kopya.rar (Dosya Boyutu: 134,37 KB | İndirme Sayısı: 14)
Access Çekirgesi 
[Resim: img-cray.gif]


Son Düzenleme: 09/04/2021, 15:00, Düzenleyen: Oğuz Türkyılmaz.
Cevapla
#2
(09/04/2021, 01:17)Oğuz Türkyılmaz yazdı: Merhaba

Bu kodları internette konuyla alakalı araştırma yaparken buldum fakat uygulama dosyası rar ile açıldığında hasarlı olduğundan kodlarla işleyiş arasında bağlantı kuramadığımdan bu kodları kendi projeme adapte edemedim.

Bu kodları WINPERAX Excel çalışma sayfamın Ana_Sayfa sekmesinde bulunan Mail gönder butonuna basarak masa üstümde yer alan bir PDF dosyasını mail adreslerinin tümüne eklemek ve topluca mail göndermek için nasıl revize etmeliyim. Çok fazla mail adresi olduğunda gönderim esnasında ID numarasına göre başlangıç ve bitiş numaraları vererek sınırlama getirilmiş ve sorun oluşturabilecek bu durum kodda zaten çözülmüş. Ben bu kodları uygulamama nasıl adapte edebilirim. Yardımlarınız için şimdiden teşekkür ederim. Parola : 171717



Sub kod_PDF_mail()

    Klasor = Range("m36")
    On Error Resume Next
    If Dir(Klasor) = "" Then MkDir Klasor

    Dim yol_isim    As String
    Dim kayıt_yeri  As String
    Dim i          As Long
 
    kayıt_yeri = Range("M36")

    basla = InputBox("Başlangınç No")
    If basla = "" Then Exit Sub
    bitis = InputBox("Bitiş No")
    If bitis = "" Then Exit Sub

    If CreateObject("scripting.filesystemobject").folderexists(kayıt_yeri) = False Then _
            CreateObject("scripting.filesystemobject").createfolder (kayıt_yeri)

    For i = basla To bitis

        Range("N11") = i
        If Range("N14") <> "" Then
            yol_isim = Range("M37")

            Sheets("MUTABAKAT FORMU").ExportAsFixedFormat Type:=xlTypePDF, _
                    Filename:=yol_isim, _
                    Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
                    OpenAfterPublish:=False
                 
            With Application
                .EnableEvents = True
            End With
            Dim objOutlook As Object
            Dim objMail As Object
            Dim NoA As Long
            Set objOutlook = CreateObject("Outlook.Application")
            Set objMail = objOutlook.CreateItem(0)
            With objMail
                .To = Range("N21")
                .cC = Range("N20")
                .Subject = Range("M35")
                .body = "Sayın yetkili, Ekte tarafınıza ait mutabakat mektubu bulunmaktadır. En kısa sürede geri dönüşünüzü bekliyoruz. Saygılarımızla,"
                .Attachments.Add yol_isim
                .Importance = 2
                .Save
                .Display
                '.Send ' gönder
                Sheets("Aktif Bayiler").Cells(i + 6, "R") = "Mail gönderildi"
            End With
        End If
    Next i
    Set objMail = Nothing
    Set objOutlook = Nothing

End Sub

[Resim: do.php?img=10875]



Merhaba,

Kontrol eder misiniz ?
.rar WINPERAX - Kopya.rar (Dosya Boyutu: 113,77 KB | İndirme Sayısı: 7)
Cevapla
#3
Sn.Kanakan52 dosyada ne gibi bir işlem yaptığınızı anlayamadım sadece mail gönder butonuna tıkladığınızda dosya seçme dialog kutusu çıkıyor doya ekle dediğinizde de herhangi bir işlem gerçekleşmiyor diye yazmıştım ki butonun olayına bakmak geldi aklıma şimdi orayı inceleyip dönüş yapacağım. Teşekkür ederim.
Access Çekirgesi 
[Resim: img-cray.gif]


Son Düzenleme: 09/04/2021, 20:29, Düzenleyen: Oğuz Türkyılmaz.
Cevapla
#4
Sn.Kanakan52  İşlem gerçekleştiğinde otomatik olarak outlooku açmıyor ben manuel olarak outlooku açtığımda mail işleminin gideceği hesapları vs hepsini Taslaklarda görüyorum fakat ekle diyerek dialog kutusundan seçtiğim dosya eklenmiş olarak gözükmüyor. İkinci defa mail göndermek istediğimde ise işlem hiç gerçekleşmiyor.

[Resim: do.php?img=10876]

Private Sub CommandButton2_Click()
On Error Resume Next
Dim son As Integer
son = Range("F65536").End(3).Row
dosya = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)

For i = 2 To Sayfa1.Range("a65536").End(3).Row
Mail = Mail + ";" + Sayfa1.Cells(i, 4).Value
Next i

    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim MySignature As Object
   
    Set FSO = CreateObject("Scripting.FilesystemObject")
   
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
 

 
    With OutlookMsg


.To = Mail
.cC = "buraya cc yazılacak"
.Subject = Sayfa1.Cells(i, 3).Value
.body = "mesajı buraya yazın"
.Attachments.Add dosya
.Importance = 2
.Save
.Display
.Send ' en baştaki tek tırnağı kaldırırsanız doğrudan gönderir

    End With
 
     
    Set MySignature = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set FSO = Nothing

End Sub
Access Çekirgesi 
[Resim: img-cray.gif]


Son Düzenleme: 09/04/2021, 21:15, Düzenleyen: Oğuz Türkyılmaz.
Cevapla
#5
Kodları aşağıdaki gibi revize ettim şu an PDF formatında dosyaları dialog kutusundan seçip ekleyerek gönderebiliyorum fakat Excel ve word dosyalarını eklemek mümkün olmuyor. Sorunun nedeni konusunda bilgilendirirseniz çok makbule geçecek. Son olarak öğrenmek istediğim bu dosyada 3 ila 4 bin arası mail adresi olacak. For döngüsü ile tüm mail adreslerini bu şekilde eklemek outlook da sorun olur diye okudum ve her satırdaki ID ye göre başlangıç ve bitiş numarası vererek bir seferde sorunsuz kaç mail gönderebileceğim konusu nasıl çözülebilir fikriniz varsa öğrenmek isterim. Çok teşekkürler.



Private Sub CommandButton2_Click()
On Error Resume Next
Dim son As Integer


son = Range("F65536").End(3).Row
ek = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)

For i = 2 To Sayfa1.Range("a65536").End(3).Row
Mail = Mail + ";" + Sayfa1.Cells(i, 7).Value
Next i

    Dim OutlookApp As Object, OutlookMsg As Object
    Dim FSO As Object
    Dim MySignature As Object
   
    Set FSO = CreateObject("Scripting.FilesystemObject")
   
    Set OutlookApp = CreateObject("Outlook.Application")
    Set OutlookMsg = OutlookApp.CreateItem(0)
 

 
    With OutlookMsg


.To = Mail
.cC = "buraya cc yazılacak"
.Subject = Sayfa1.Cells(i, 3).Value
.body = "mesajı buraya yazın"
.Attachments.Add ek
.Importance = 2
.Save
.Display
.Send

    End With
 
     
    Set MySignature = Nothing
    Set OutlookMsg = Nothing
    Set OutlookApp = Nothing
    Set FSO = Nothing

End Sub

[Resim: do.php?img=10877]
Access Çekirgesi 
[Resim: img-cray.gif]


Son Düzenleme: 09/04/2021, 23:27, Düzenleyen: Oğuz Türkyılmaz.
Cevapla
#6
Alttaki gibi deneyiniz.Yalnız .cC = "cc yaz" bu satır olursa hata veriyor.

Private Sub CommandButton2_Click()

    Dim objOutlook As Object
    Dim objMail As Object
    Dim maill As String
    Dim i As Long, dosya
    Dim syfAna As Worksheet
   
    Set syfAna = ThisWorkbook.Sheets("Ana_Sayfa")
    dosya = Application.GetOpenFilename("Files (*.**)," & "*.**", 1, "Select File", "Open", False)
    If dosya = vbNullString Then Exit Sub
    If dosya = False Then Exit Sub

    basla = InputBox("Baþlangýnç No")
    If basla = "" Then Exit Sub
    bitis = InputBox("Bitiþ No")
    If bitis = "" Then Exit Sub
    If WorksheetFunction.CountA(syfAna.Range("D2Lol" & Rows.Count)) = 0 Then GoTo son
    For i = basla To bitis
        maill = maill & syfAna.Range("D" & i) & ";"
    Next
    maill = Left(maill, Len(maill) - 1)

        Set objOutlook = CreateObject("Outlook.Application")
        Set objMail = objOutlook.CreateItem(0)
        With objMail
            .To = maill
            .cC = "cc yaz"
            .Subject = "Konu yaz"
            .body = "Sayýn yetkili, Ekte tarafýnýza ait mutabakat mektubu bulunmaktadýr. En kýsa sürede geri dönüþünüzü bekliyoruz. Saygýlarýmýzla,"
            .Attachments.Add dosya
            .Importance = 2
            .Save
            .Display
            '.Send ' gönder
        End With
        MsgBox "Gönderildi..", vbInformation, "Bilgi"
var:
    Set objMail = Nothing
    Set objOutlook = Nothing
    Set syfAna = Nothing
    Exit Sub
son:
MsgBox "Hata oldu", vbCritical, "Hata"
GoTo var
End Sub
Cevapla

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

Yorum yapmak için üye olmanız gerekiyor

ya da
Task