ilgili sayfayı belirlenen sütundaki mail adreslerine PDF gönder

[Gold_Savt]

Anasayfada bulunan mail adreslerine sadece "yazdir" sayfasını PDF olarak göndermek istiyorum.
Ekli dosyada ".xlsx" olarak gönderme makrosu var. Düzenleme şansımız var mıdır arkadaşlar.

 

[Gold_Savt]

Günceldir.

 

[Korhan Ayhan]

İnceleyiniz.

Excel mail'i PDF olarak atma

Arkadaşlar, hocalarımız. Ben iş yerinde çok sayıda mail atıyorum. Excel yapacağım. Her sayfasına atacağım mail'i hazırlayacağım. (zaten her mail 1 A4 sadece) Benim mail adresim muratgunay@..........com yani şirket maili. Mailler benim mailimden atılmış gibi gidecek. Ben sayfaları hazırlayıp...

www.excel.web.tr

 

[Gold_Savt]

Araştırdım ama malesef sağlıklı bir netice elde edemedim.
"yazdir" sayfasını pdf olarak göndermek istiyorum.
"Anasayfa"daki M8 den başlayan M1000 arasındaki dolu mail adreslerine mail olarak göndermem gerekiyor.
Bir dokunuş yapabilecek var mı acama?

 

[Korhan Ayhan]

Mailler her mail adresi için ayrı ayrımı gönderilecek? Yoksa tümüne toplu olarak tek bir mailde gönderilse olur mu?

Tek tek gönderecek şekilde kurguladığım kodları deneyebilirsiniz.

Gönderim adedi çok olacağı için her mail arasına 5 saniye bekleme süresi ekledim.
Daha önce başka bir başlıkta paylaştığım kodu kullandığım için mail gövdesindeki mesajı değiştirmedim. Kendinize göre düzenlersiniz.

Option Explicit

Dim Yol As String, Dosya_Adi As String
Dim Uygulama As Object, Yeni_Mail As Object
Dim S1 As Worksheet, Onay As Byte, Mesaj As String, Adres As Range

Sub PDF_KAYDET_MAIL_GONDER()
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
   
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
   
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Set S1 = Sheets("yazdir")
   
    Yol = ThisWorkbook.Path
    Dosya_Adi = "yazdir " & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"
    ChDir Yol
       
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
   
    If Onay = vbYes Then
        S1.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=Yol & "\" & Dosya_Adi, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
       
        Mesaj = "Merhaba Sayın Yetkili,<br><br>" & "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.<br><br>" & _
                "Firmamızdan teklif almak suretiyle göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
       
        Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'><b>" & Mesaj & "</b></font></p>"
       
        For Each Adres In Sheets("Anasayfa").Range("M8:M1000").SpecialCells(xlCellTypeConstants, 6)
            DoEvents
            If Adres.Value <> "" Then
                With Yeni_Mail
                    .Display
                    .To = Adres.Value
                    .CC = ""
                    .BCC = ""
                    .Subject = Left(Dosya_Adi, Len(Dosya_Adi) - 4)
                    .HTMLBody = Mesaj & .HTMLBody
                    .Attachments.Add Yol & "\" & Dosya_Adi
                    .BodyFormat = 2
                    .Save
                    .Send
                End With
                Application.Wait Now + TimeValue("00:00:05")
            End If
        Next
       
        Kill Yol & "\" & Dosya_Adi
       
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
   
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub

 

[Gold_Savt]

Tüm mail adreslerine Tek seferde bir mail atılacak hocam.

Aşağıdaki kısım debug hatası veriyor
S1.ExportAsFixedFormat Type:=xlTypePDF, _
FileName:=Yol & "\" & Dosya_Adi, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

 

[Korhan Ayhan]

Siz normal bir excel dosyasını farklı kaydet diyerek PDF biçiminde kayıt edebiliyor musunuz? Bunu kontrol ediniz. Eğer bu işlemi yapabiliyorsanız kodların hata vermemesi gerekir. Eğer yapamıyorsanız daha üst Excel versiyonlarına geçmenizde fayda var.

 

[Korhan Ayhan]

Bütün adreslere tek bir mail gidecek demişsiniz.

Aşağıdaki kod bu şekilde gönderim yapar.

Option Explicit

Dim Yol As String, Dosya_Adi As String
Dim Uygulama As Object, Yeni_Mail As Object, Veri As Range
Dim S1 As Worksheet, Onay As Byte, Mesaj As String, Adres As String

Sub PDF_KAYDET_MAIL_GONDER()
    On Error Resume Next
    Set Uygulama = GetObject(, "Outlook.Application")
    On Error GoTo 0
    
    If Uygulama Is Nothing Then Call Shell("Outlook.exe", vbHide)
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Set S1 = Sheets("yazdir")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = "yazdir " & Format(Now, "dd-mmm-yy h-mm-ss") & ".pdf"
    ChDir Yol
        
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    
    If Onay = vbYes Then
        S1.ExportAsFixedFormat Type:=xlTypePDF, _
        FileName:=Yol & "\" & Dosya_Adi, _
        Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, _
        OpenAfterPublish:=False
        
        Mesaj = "Merhaba Sayın Yetkili,<br><br>" & "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.<br><br>" & _
                "Firmamızdan teklif almak suretiyle göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
        
        Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'><b>" & Mesaj & "</b></font></p>"
        
        With Yeni_Mail
            .Display
             For Each Veri In Sheets("Anasayfa").Range("M8:M1000").SpecialCells(xlCellTypeConstants, 6)
                 If Veri.Value <> "" Then
                     Adres = IIf(Adres = "", Veri.Value, Adres & ";" & Veri.Value)
                 End If
             Next
            .To = Adres
            .CC = ""
            .BCC = ""
            .Subject = Left(Dosya_Adi, Len(Dosya_Adi) - 4)
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Yol & "\" & Dosya_Adi
            .BodyFormat = 2
            .Save
            .Send
        End With
        
        Kill Yol & "\" & Dosya_Adi
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    Else
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    End If
    
    Set S1 = Nothing
    Set Yeni_Mail = Nothing
    Set Uygulama = Nothing
End Sub