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