Makro ile pdf Kaydedilen dosyayı Mail Gönderme

[Korhan Ayhan]

Aşağıdaki kodu deneyiniz.

A1 hücresinde pdf dosyanın adı yazılacak.
A2 hücresinde mailin konusu yazılacak.
A3 hücresinde mail gövdesinde (penceresinde) görünmesi istenen metin yazılacak.
A4 hücresinde mail gönderilecek adres yazılacak.

Bu hücre adreslerini dilediğiniz gibi değiştirebilirsiniz.

Kod aktif sayfadaki yazdırma alanını pdf olarak excel dosyasının bulunduğu klasöre kayıt edip mail olarak gönderir. Kodların çalışması için en az 2010 excel versiyonu gereklidir.

Sub PDF_KAYDET_MAIL_GONDER()
    Dim Uygulama As Object
    Dim Yeni_Mail As Object
    
    If Range("A1").Value = "" Then
        MsgBox "Lütfen dosya adını yazınız!", vbCritical
        Exit Sub
    End If

    Yol = ThisWorkbook.Path
    Dosya_Adi = Range("A1").Value & ".pdf"

    Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    With Yeni_Mail
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Yol & "\" & Dosya_Adi
        .Save
        If Range("A4").Value = "" Then
            .To = ""
            .Display
        Else
            .To = Range("A4").Value
            .Send
            MsgBox "Mail gönderildi."
        End If
    End With
    
    Set Uygulama = Nothing
    Set Yeni_Mail = Nothing
End Sub

 

[kartalkartal]

Günaydın,

Aşağıdaki yer hata veriyor.

Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Yol & "\" & Dosya_Adi, _
Quality:=xlQualityStandard, _
IncludeDocProperties:=True, _
IgnorePrintAreas:=False, _
OpenAfterPublish:=False

iyi çalışmalar.

Teşekkürler

 

[Korhan Ayhan]

Profilinizdeki excel sürüm bilgisini güncelleyiniz.

Hangi excel versiyonunu kullanıyorsunuz. Bu kodun çalışması için en az 2010 sürümünü kullanmanız gerekiyor.

Ek olarak sayfada yazdırma alanı belirlenmiş durumda mı?

 

[kartalkartal]

Merhaba,

Aşağıdaki kodu kullandım oldu,tam istediğim gibi değil ama işimi görüyor.
1- mesaj Pdf kaydetmek istiyormusun.
2-Mail ile göndermek istiyormusun.
3-maile ek döküman eklemek istiyormusun gibi seçenekli olmasını istiyordum ama beceremedim.
Benim gibi kullanmak istiyenler kendisine uyarlayıp kulllanabilirler.

Kolay gelsin.

Option Explicit

Dim Yol As String
Dim Dosya_Adi As String
Dim Outlook_App As Object
Dim Outlook_Mail As Object
Dim S1 As Worksheet

Sub PDF_KAYDET_MAIL_GONDER()
    Set S1 = Sheets("FORM")
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("O2") & " --- YAYIN DEĞİŞİKLİK BİLDİRİSİ.pdf"
    ChDir Yol
    
    S1.Range("A2:P36").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    Set S1 = Nothing
    
    MsgBox "İşleminiz tamamlanmıştır.", vbInformation


    Set Outlook_App = CreateObject("Outlook.Application")
    Set S1 = Sheets("FORM")
    
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    With Outlook_Mail
        .To = S1.Range("S11")
        .CC = S1.Range("S12")
        .Subject = S1.Range("S13")
        .Body = "Merhabalar," & Chr(10) & Chr(10) & _
                "Yayın değişikliği bilgisi ekte bilgilerinize sunulmuştur. " & Chr(10) & Chr(10) & Chr(10) & _
                "Saygılarımızla."
                
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Korhan Ayhan]

Mesajla uyarı yöntemi için aşağıdaki gibi kullanabilirsiniz.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet

Sub PDF_KAYDET_MAIL_GONDER()
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("O2") & " --- YAYIN DEĞİŞİKLİK BİLDİRİSİ.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.Range("A2:P36").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

    With Outlook_Mail
        .To = S1.Range("S11").Value
        .Cc = S1.Range("S12").Value
        .Subject = S1.Range("S13").Value
        .Body = "Merhabalar," & Chr(10) & Chr(10) & _
                "Yayın değişikliği bilgisi ekte bilgilerinize sunulmuştur." & Chr(10) & Chr(10) & Chr(10) & _
                "Saygılarımızla."
                
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kartalkartal]

Günaydın,

Teşekkür ederim,iyi çalışmalar.

 

[kartalkartal]

Merhaba,

Outlook imzasını eklemesi koda eklendi.

iyi çalışmalar.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet

Sub PDF_KAYDET_MAIL_GONDER()
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("O2") & " --- YAYIN DEĞİŞİKLİK BİLDİRİSİ.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.Range("A2:P36").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

Dim Signature, MS As Object
If Dir("C:\Users\Kullanıcı\Desktop\signature.htm") = "" Then
MsgBox "C:\Users\Kullanıcı\Desktop\signature.htm" & " dosyası bulunamadı..."
Exit Sub
End If
Set MS = CreateObject("Scripting.FilesystemObject")
Set Signature = MS.OpenTextFile("C:\Users\Kullanıcı\Desktop\signature.htm", 1)


    With Outlook_Mail
        .To = S1.Range("S11").Value
        .CC = S1.Range("S12").Value
        .Subject = S1.Range("S13").Value
        
        .Body = "Merhabalar," & Chr(10) & Chr(10) & _
                "Yayın değişikliği bilgisi ekte bilgilerinize sunulmuştur." & Chr(10) & Chr(10) & Chr(10) & _
                "Saygılarımızla."
         .HTMLBody = .HTMLBody & "<br><br><br>" & Signature.ReadAll
       
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    
End Sub

 

[kartalkartal]

Merhaba Arkadaşlar,

Aşağıdaki kod gayet güzel çalışıyor,fakat aynı sayfada 10 adet form var ,bunlardan 3 adedi dolu ise bu kodda hangi aralı yazılı ise onu pdf atıyor,oysaki ikinci kodda öyle bir sıkıntı yok hangi form dolu ise o kadar sayfa görünecek şekilde pdf atıyor ,şimdi bu iki kodu birleştirmeyi nasıl yapabiliriz.

iyi çalışmalar.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet

Sub PDF_KAYDET_MAIL_GONDER()
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("s2") & " --- ÇIKIŞ KALİTE KONTROL RAPORU.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.Range("A1:P39").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

Dim Signature, MS As Object
If Dir("\\05-Ç.K.K\signature.htm") = "" Then
MsgBox "\\05-Ç.K.K\signature.htm" & " dosyası bulunamadı..."
Exit Sub
End If
Set MS = CreateObject("Scripting.FilesystemObject")
Set Signature = MS.OpenTextFile("\\05-Ç.K.K\signature.htm", 1)


    With Outlook_Mail
        .To = S1.Range("T22").Value
        .CC = S1.Range("T23").Value
        .Subject = S1.Range("T24").Value
        
        .Body = "Merhaba," & Chr(10) & Chr(10) & _
                "Çkk raporu  ektedir."

         .HTMLBody = .HTMLBody & "<br><br><br>" & Signature.ReadAll
       
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    ActiveWorkbook.Save


    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    
End Sub

ikinci kod

Sub farklı_kaytet_pdf()
ActiveSheet.PageSetup.PrintArea = "$B$2:$M$" & Range("A65536").End(3).Row
Set ac = Application.FileDialog(msoFileDialogSaveAs)

Yol = ThisWorkbook.Path
Dosya_adı = Cells(1, "S").Value
If Dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")
If a = vbYes Then
ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & Dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
ActiveWorkbook.Save

MsgBox isim & " ismiyle" & vbCrLf _
& Yol & " dosya yoluna kaydedilmiştir."
End If
If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
End If
End Sub

 

[kartalkartal]

Merhaba Arkadaşlar,

Konu hakkında fikir verebilecek arkadaşlar yokmu?

iyi çalışmalar.

 

[Korhan Ayhan]

Aşağıdaki gibi deneyiniz.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet
Dim Imza As Variant, FSO As Object

Sub PDF_KAYDET_MAIL_GONDER()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("s2") & " --- ÇIKIŞ KALİTE KONTROL RAPORU.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.PageSetup.PrintArea = "$B$2:$M$" & S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

    On Error Resume Next
    If Dir("C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm") = "" Then
        MsgBox "C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm" & "İmza dosyası bulunamadı..."
        Exit Sub
    Else
        Set Imza = FSO.OpenTextFile("C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm", 1)
    End If
    On Error GoTo 0
    

    With Outlook_Mail
        .To = S1.Range("T22").Value
        .CC = S1.Range("T23").Value
        .Subject = S1.Range("T24").Value
        
        .Body = "Merhaba," & Chr(10) & Chr(10) & _
                "Çkk raporu ektedir."

         If Imza Is Nothing Then
            .HTMLBody = .HTMLBody & "<br><br><br>"
         Else
            .HTMLBody = .HTMLBody & "<br><br><br>" & Imza.ReadAll
         End If
         
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    ActiveWorkbook.Save

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kartalkartal]

Merhaba,

Çok teşekkür ederim Korhan Bey,

İyi çalışmalar.

 

[kartalkartal]

Merhaba,

Aşağıdaki kod çok güzel çalışıyor fakat mail gövdesine dosya yoluda ekleyebiliyorum.

1-Eklenen dosya yolunun köprü olarak açılması olmuyor.
2-O dosya yolundaki dosyanında maile eklenmesi .(aşağıdaki ikinci kod bu işlemi yapıyor)
Bu iki kodu birleştirmyei denedim ama yapamadım,konu hakkında yardımcı olabilirmisiniz.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet
Dim Imza As Variant, FSO As Object

Sub PDF_KAYDET_MAIL_GONDER()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("s2") & " --- ÇIKIŞ KALİTE KONTROL RAPORU.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.PageSetup.PrintArea = "$B$2:$M$" & S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

    On Error Resume Next
    If Dir("C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm") = "" Then
        MsgBox "C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm" & "İmza dosyası bulunamadı..."
        Exit Sub
    Else
        Set Imza = FSO.OpenTextFile("C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\İmzam.htm", 1)
    End If
    On Error GoTo 0
    

    With Outlook_Mail
        .To = S1.Range("T22").Value
        .CC = S1.Range("T23").Value
        .Subject = S1.Range("T24").Value
        
        .Body = "Merhaba," & Chr(10) & Chr(10) & _
                "Çkk raporu ektedir."

         If Imza Is Nothing Then
            .HTMLBody = .HTMLBody & "<br><br><br>"
         Else
            .HTMLBody = .HTMLBody & "<br><br><br>" & Imza.ReadAll
         End If
         
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    ActiveWorkbook.Save

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

İkinci kod.

Sub topluMailGonder()
Dim outapp As Object
Dim outmail As Object
On Error Resume Next
bos = 5
' If CheckBox1 = True Then
'    adres = "3"
' Else: adres = "4"
' End If

While bos <= Sayfa1.Range("a3000").End(xlUp).Row
  
Set outapp = New Outlook.Application
Set outmail = outapp.createitem(0)
  
With outmail
       If Sayfa1.Range(Sayfa1.Range("j1") & bos) = "" Or Sayfa1.Range("A" & bos).RowHeight = 0 Then
        GoTo yok
       End If
      .To = Sayfa1.Range(Sayfa1.Range("j1") & bos)   'gönderilecek e mail
      .CC = Sayfa1.Range("B1")
      .BCC = Sayfa1.Range("B2")
      .HTMLBody = " <src=""d:\sahinKar.jpg"">"
      .Subject = Sayfa1.Range("D1")  'konu kısmı
      '.Body = Sayfa1.Range("A3")  'mesaj kısmı
      If Sayfa1.Range("d2") <> "" Then
          .Attachments.Add (Sayfa1.Range("d2"))    ' dosya ekleme
      End If
      .Importance = Sayfa1.Range("f1")   '2 önem düzeyi yüksek 1 Normal 0 düşük
      .send
      '.Display
End With
Set outmail = Nothing
Set outapp = Nothing
yok:
bos = bos + 1
Wend
End Sub

 

[Korhan Ayhan]

Kaydedilen dosyayı mail penceresine LİNK olarak ekler.

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet
Dim Imza As Variant, Imza_Yolu As String, FSO As Object

Sub PDF_KAYDET_MAIL_GONDER()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("s2") & " --- ÇIKIŞ KALİTE KONTROL RAPORU.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.PageSetup.PrintArea = "$B$2:$M$" & S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

    Imza_Yolu = "C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\imzam.htm"

    On Error Resume Next
    If Dir(Imza_Yolu) = "" Then
        MsgBox Imza_Yolu & "İmza dosyası bulunamadı..."
        Exit Sub
    Else
        Set Imza = FSO.OpenTextFile(Imza_Yolu, 1)
    End If
    On Error GoTo 0
    

    With Outlook_Mail
        .To = S1.Range("T22").Value
        .CC = S1.Range("T23").Value
        .Subject = S1.Range("T24").Value
        
        .Body = "Merhaba," & Chr(10) & Chr(10) & _
                "Çkk raporu ektedir."

         If Imza Is Nothing Then
            .HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & Dosya_Adi & "'>Dosya</a>.)"
         Else
            .HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & Dosya_Adi & "'>Dosya</a>.)" & Imza.ReadAll
         End If
         
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    ActiveWorkbook.Save

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[kartalkartal]

Merhaba,

Teşşekür ederim Korhan Bey.
Uygun bir zamanda kodu deneyeceğim.
İyi çalışmalar.
Kolay gelsin.

 

[kartalkartal]

Merhaba,

Teşekkür ederim.

Asıl istediğim o dosyayıda maile eklemesi idi ama olsun buda işimi görüyor ,dosya adı yerine Range yazdığımda köprü harika oldu.

İyi çalışmalar.

 .HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & Dosya_Adi & "'>Dosya</a>.)"
.HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & S1.Range("S25").Value & "'>Dosya</a>.)"

 

[Korhan Ayhan]

Merhaba,

Kod içindeki aşağıdaki satır ile dosya zaten maile ekleniyor olması gerekir.

.Attachments.Add Dosya_Adi

 

[kartalkartal]

Merhaba,

Dosyayı eklemiyordu,aşağıdaki koda Dosya _Adi yazan yere (S1.Range("S25") yazdığımda sadece dosya yolundaki dosyayı ekledi,diğer eklemek istediğim dosyayı eklemedi.

.Attachments.Add Dosya_Adi

Aşağıdaki kodları ilave yaptım oldu.

If S1.Range("s25") <> "" Then
                 .Attachments.Add (S1.Range("s25"))   
                   End If

Tam kod

Option Explicit

Dim Outlook_Uygulamasi As Object
Dim Outlook_Mail As Object
Dim Yol As String
Dim Dosya_Adi As String
Dim S1 As Worksheet
Dim Imza As Variant, Imza_Yolu As String, FSO As Object

Sub PDF_KAYDET_MAIL_GONDER()
    Set FSO = CreateObject("Scripting.FileSystemObject")
    Set Outlook_Uygulamasi = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_Uygulamasi.CreateItem(0)
    Set S1 = Sheets("FORM")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Range("s2") & " --- ÇIKIŞ KALİTE KONTROL RAPORU.pdf"
    ChDir Yol
    
    If MsgBox("PDF olarak kayıt etmek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son
    
    S1.PageSetup.PrintArea = "$B$2:$M$" & S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    S1.ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False
    
    If MsgBox("PDF dosyasını mail olarak göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı") = vbNo Then GoTo Son

    Imza_Yolu = "C:\Users\XXXXX\AppData\Roaming\Microsoft\Signatures\imzam.htm"

    On Error Resume Next
    If Dir(Imza_Yolu) = "" Then
        MsgBox Imza_Yolu & "İmza dosyası bulunamadı..."
        Exit Sub
    Else
        Set Imza = FSO.OpenTextFile(Imza_Yolu, 1)
    End If
    On Error GoTo 0
    

    With Outlook_Mail
        .To = S1.Range("T22").Value
        .CC = S1.Range("T23").Value
        .Subject = S1.Range("T24").Value
        
        .Body = "Merhaba," & Chr(10) & Chr(10) & _
                "Çkk raporu ektedir."
                 If S1.Range("s25") <> "" Then
                 .Attachments.Add (S1.Range("s25"))    ' dosya ekleme
                 End If
         If Imza Is Nothing Then
            .HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & Dosya_Adi & "'>Dosya</a>.)"
         Else
            .HTMLBody = .HTMLBody & "<br><br><br>" & "(Ayrıntılar için dosyayı inceleyiniz.. <a href='" & Dosya_Adi & "'>Dosya</a>.)" & Imza.ReadAll
         End If
         
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
        .Display
    End With
    
Son:
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_Uygulamasi = Nothing
    ActiveWorkbook.Save

    MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub

 

[Datalay]

Aşağıdaki kodu deneyiniz.

A1 hücresinde pdf dosyanın adı yazılacak.
A2 hücresinde mailin konusu yazılacak.
A3 hücresinde mail gövdesinde (penceresinde) görünmesi istenen metin yazılacak.
A4 hücresinde mail gönderilecek adres yazılacak.

Bu hücre adreslerini dilediğiniz gibi değiştirebilirsiniz.

Kod aktif sayfadaki yazdırma alanını pdf olarak excel dosyasının bulunduğu klasöre kayıt edip mail olarak gönderir. Kodların çalışması için en az 2010 excel versiyonu gereklidir.

Sub PDF_KAYDET_MAIL_GONDER()
    Dim Uygulama As Object
    Dim Yeni_Mail As Object
    
    If Range("A1").Value = "" Then
        MsgBox "Lütfen dosya adını yazınız!", vbCritical
        Exit Sub
    End If

    Yol = ThisWorkbook.Path
    Dosya_Adi = Range("A1").Value & ".pdf"

    [COLOR="Red"]Range("Print_Area").ExportAsFixedFormat Type:=xlTypePDF, _
    Filename:=Yol & "\" & Dosya_Adi, _
    Quality:=xlQualityStandard, _
    IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, _
    OpenAfterPublish:=False[/COLOR]
    
    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    With Yeni_Mail
        .Subject = Range("A2").Value
        .Body = Range("A3").Value
        .Attachments.Add Yol & "\" & Dosya_Adi
        .Save
        If Range("A4").Value = "" Then
            .To = ""
            .Display
        Else
            .To = Range("A4").Value
            .Send
            MsgBox "Mail gönderildi."
        End If
    End With
    
    Set Uygulama = Nothing
    Set Yeni_Mail = Nothing
End Sub

Merhaba Korhan Bey,

Yazdığınız kodda kırmızı ile belirttiğim kısım bende neden hata veriyor. Nerede hata yapıyorum, yardımcı olur musunuz. (Yazdırma alanı belirlendi, excel 2010)

 

[Datalay]

Ayrıca, outlok üzerinden mi gönderiliyor? Kod içerisinde yer alıyor. Bana lazım olan gmail üzerinden, excel içeriğinde belirtilen bilgilerle mail göndermek.
Teşekkür eder, iyi çalışmalar dilerim.

 

[Datalay]

Gmail üzerinden exceldeki verilere göre mail gönderme konusunda yardımcı olabilecek biri yok mu acaba?