Makro ile pdf Kaydedilen dosyayı Mail Gönderme

[Korhan Ayhan]

Merhaba,

Kırmızı bölümde hata için aşağıdaki seçenekleri kontrol ediniz.

A1 hücresinde dosya adı yazıyor mu?

Dosya_Adi = Range("A1").Value & ".pdf"

Ayrıca Range("Print_Area") ifadesi yerine Range("A1:K20") gibi yazdırma aralığı adresini yazıp deneme yapın.

Gmail üzerinden mail göndermek için açmış olduğunuz diğer başlıkta bağlantı adresi vermiştim. Onu incelerseniz örnekler verilmiş.

Outlok dışında otomatik mail

 

[erkansevinc]

.Body = Range("A3").Value

Burada ben A3 den atıyorum A6 ya kadar olan satırları yazmak istiyorum. a3:a6 diyorum olmuyor araya virgül koyuyorum olmuyor ne yapmam lazım ?

 

[erkansevinc]

birde bu dosyayı PDF yerine excel olarak kaydedip göndermek istersek ne değişiklik yapmamız lazım.

yardımlarınız için teşekkürler.

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

 

[Korhan Ayhan]

İlk sorunuz;

Eğer mesaj penceresinde bahsettiğiniz hücreleri yan yana ve aralarında boşluk ekleyerek maile yazdırmak isterseniz aşağıdaki gibi kullanın.

.Body = Range("A3").Value & " " & Range("A4").Value & " " & Range("A5").Value & " " & Range("A6").Value

Aynı hücreleri alt alta maile yazdırmak isterseniz aşağıdaki gibi kullanabilirsiniz.

.Body = Range("A3").Value & Chr(10) & Range("A4").Value & Chr(10) & Range("A5").Value & Chr(10) & Range("A6").Value

İkinci sorunuz;

Kod sayfadaki yazdırma alanını PDF olarak maile ekliyor. Siz dosyayı komple mi (tüm sayfaları) eklemek istiyorsunuz? Yoksa sadece aktif sayfayı mı?

Ek olarak bu konuyla ilgili faydalı bir kaynak olan aşağıdaki linki incelemenizi öneriyorum. Güzel örnekler var.

http://www.rondebruin.nl/win/section1.htm

 

[Erkan2003]

objEmail.Send satırında hata veriyor ne yapmam gerekiyor.

Sizin kodunuzu deneme şansım olmadı çünkü aotluk kurulu değil ama aşağıdaki kod denenmiştir.

gmail hesabından mail göndermektedir.

açıklama

d6 hücresine dosya adını yazdım (deneme dosya.pdf)
d10 hücresine konu adını yazdım (merhaba)
d12 hücresine mail gönderecğim kişinin mail adresini yazdım (kullanıcı@hotmail.com)

ve kodu çalıştırdım.

kodun çalışması için aşağıdaki kırmızı yerlere kullanıcı hesabı ve parolayı yazmanız yeterli.

Sub mailgönder()

dosya_adı = Cells(6, "D").Value

If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
Exit Sub
End If


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


Set objEmail = CreateObject("CDO.Message")

kullanici_sahibi = "[COLOR="Red"]kullanıcı@gmail.com[/COLOR]"
kullanici_parola = "[COLOR="red"]123456[/COLOR]"

objEmail.From = kullanici_sahibi ' Gönderilen e-mail adresi
objEmail.To = Cells(12, 4) ' Gönderilecek e-mail adresi

objEmail.Subject = Cells(10, 4)
'objEmail.Textbody = "Test Text Body"

Txt1 = "Merhaba Sayın Yetkili," & "<br>"
Txt2 = "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.Firmamızdan teklif almak suretiyle" & "<br>"
Txt3 = "göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
objEmail.HTMLBody = "<font size=3 face=Calibri color=red>" & Txt1 & Txt2 & Txt3

objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
With objEmail.Configuration.Fields

.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = kullanici_sahibi '"kullanıcı@hotmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = kullanici_parola '"parola"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update

End With
objEmail.Send

MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

Bu kodları kullanmaya çalıştım fakat
objEmail.Send
Satırında hata veriyor ne yapmam gerekiyor?

 

[halit3]

Bu kodları kullanmaya çalıştım fakat
objEmail.Send
Satırında hata veriyor ne yapmam gerekiyor?

Açıklamanın başında da yazmıştım öncelikle gmail hesabınız olmalı
örnek hesap deneme1@gmail.com gibi

D4 hücresine pdf adı yazılmalı örnek veri.pdf gibi

D12 hücresine mail göndereceğiniz mail yazılmalı örnek ahmet005@hotmail.com gibi

D10 hücresine konu başlığı yazmalısınız

diğer taraftan kodun içinde bu bölüme kullanıcı adı ve parolayı yazmalısınız.

kullanici_sahibi = "[COLOR="Red"]kullanıcı@gmail.com[/COLOR]"
kullanici_parola = "[COLOR="red"]123456[/COLOR]"

Ayrıca bilgisayarınızda kısıtlamalar olmamalı

 

[Erkan2003]

Halit bey teşekkürler,

Kodlar bu şekilde

Sub mailgönder()

dosya_adı = Cells(4, "L").Value & " " & Cells(11, "D").Value & " " & Cells(9, "C").Value & " " & ".pdf"

If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
Exit Sub
End If


ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


Set objEmail = CreateObject("CDO.Message")

kullanici_sahibi = "erkanselek2003@gmail.com"
kullanici_parola = "*******"

objEmail.From = kullanici_sahibi ' Gönderilen e-mail adresi
objEmail.To = Cells(12, "Q") ' Gönderilecek e-mail adresi

objEmail.Subject = Cells(10, "Q")
'objEmail.Textbody = "Test Text Body"

Txt1 = "Merhaba Sayın Yetkili," & "<br>"
Txt2 = "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.Firmamızdan teklif almak suretiyle" & "<br>"
Txt3 = "göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
objEmail.HTMLBody = "<font size=3 face=Calibri color=red>" & Txt1 & Txt2 & Txt3

objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
With objEmail.Configuration.Fields

.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = kullanici_sahibi '"kullanıcı@hotmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = kullanici_parola '"parola"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update

End With
objEmail.Send

MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

 

[halit3]

Birde kodu bu şekilde dene sadece kırmızı yere şifrenizi giriniz.

Sub mailgönder()

dosya_adı = Cells(4, "L").Value & " " & Cells(11, "D").Value & " " & Cells(9, "C").Value & " " & ".pdf"

If dosya_adı = "" Then
MsgBox "Dosya adı yok"
Exit Sub
End If
a = MsgBox(" Kayıt etmek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
Exit Sub
End If


'ActiveSheet.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
ThisWorkbook.Path & "\" & dosya_adı, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False


Set objEmail = CreateObject("CDO.Message")

kullanici_sahibi = "erkanselek2003@gmail.com"
kullanici_parola = "[COLOR="Red"]*******[/COLOR]"

objEmail.From = kullanici_sahibi ' Gönderilen e-mail adresi
objEmail.To = Cells(12, "Q") ' Gönderilecek e-mail adresi

objEmail.Subject = Cells(10, "Q")
'objEmail.Textbody = "Test Text Body"

Txt1 = "Merhaba Sayın Yetkili," & "<br>"
Txt2 = "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.Firmamızdan teklif almak suretiyle" & "<br>"
Txt3 = "göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
objEmail.HTMLBody = "<font size=3 face=Calibri color=red>" & Txt1 & Txt2 & Txt3

'objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
With objEmail.Configuration.Fields

.Item("http://schemas.microsoft.com/cdo/configuration/smtpauthenticate") = 1
.Item("http://schemas.microsoft.com/cdo/configuration/sendusername") = kullanici_sahibi '"kullanıcı@hotmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendpassword") = kullanici_parola '"parola"
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserver") = "smtp.gmail.com"
.Item("http://schemas.microsoft.com/cdo/configuration/sendusing") = 2
.Item("http://schemas.microsoft.com/cdo/configuration/smtpserverport") = 465
.Item("http://schemas.microsoft.com/cdo/configuration/smtpusessl") = True
.Update

End With
objEmail.Send

MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

 

[Erkan2003]

Halit bey,
Aynı hatayı verdi.

 

[halit3]

Halit bey,
Aynı hatayı verdi.

Bilgisayarınızda kısıtlama varmı
internet sağlayıcınız hangi firma örneğin türk telekom ttnet gibi

 

[Erkan2003]

Bilgisayarınızda kısıtlama varmı
internet sağlayıcınız hangi firma örneğin türk telekom ttnet gibi

TTnet

Bir kısıtlama yok ama gmail den engellenen oturum açma girişimi diye bir mail gelmişti ilk denememde

 

[halit3]

Bu konuda bir şey diyemiyeceğim size

 

[Erkan2003]

Güvenlik ayarını düşürünce mail gönderimi gerçekleşti çok teşekkürler Halit bey

 

[halit3]

Güvenlik ayarını düşürünce mail gönderimi gerçekleşti çok teşekkürler Halit bey

Teşekkürler iyi çalışmalar

 

[ebubik]

Mail Gönderme Makrosu Sonrası Oluşan Problem

Merhabalar,
Konu içerisindeki mail gönderme makrosunu uyguladım ancak,
Bu şekilde daha önce göndermiş olduğum pdf dosyalarına ait mailleri, herhangi bir excel sayfasını her açtığımda, excel formatında otomatik olarak açmaya başladı,
En son C:\\AppData\Roaming\Microsoft\Excel\XLSTART klasörü içerisine attığı pdf dosyalarını silerek sıkıntıdan kurtulabildim, acaba bu durum benim bilgisayarıma özgü bir sıkıntı mıdır? Kodu bu sıkıntı yüzünden kullanamıyorum.

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

 

[Korhan Ayhan]

Siz kodu neredeki dosyada çalıştırıyorsunuz?

 

[ebubik]

Kodu Personal.xlsb'den çalıştırdım...

 

[Korhan Ayhan]

Başka bir yerdeki normal bir excel dosyasında çalıştırıp deneyin. Sorun düzelecektir.

 

[ebubik]

Evet, sorun düzeldi, teşekkür ederim Korhan Bey.

 

[teneken]

merhaba,

bu başlıkta ve benzer diğer başlıklarda yazılanlardan faydalanarak mail atma işlemini başarabildim.

ancak benim yapmak istediğim, pivot tabloda bulunan bütün kişilere bir döngü ile kendi tablolarını mail atmak.

ekteki örnek tabloda göreceğiniz gibi döngünün ilk kişisine mail başarılı bir şekilde gönderiliyor. ancak ikinci turda hata veriyor.

nerede hata yaptığım ve nasıl düzelteceğim konusunda destek alabilir miyim?

şimdiden teşekkürler.