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

(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

Merhaba,

Kontrol eder misiniz ?

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.

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.

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

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

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("D2" & 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