Makro ile pdf Kaydedilen dosyayı Mail Gönderme

wesdesa · 10 Nisan 2015

tamda buydu adamın dibisin sağolasın var olasın allah klavye tuşlarına zeval vermesin..

birde son birşey sorsam;

mail atarken otomatik mesaj yazdık ya onun altına outlookta kayıtlı imza bilgimi nasıl eklerim...Teşekkürler...

Korhan Ayhan · 10 Nisan 2015

Aşağıdaki kodu deneyiniz.

Kod:

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, Onay As Byte, Mesaj As String

Sub PDF_KAYDET_MAIL_GONDER()
    Set Outlook_App = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    
    Set S1 = ActiveSheet
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Cells(6, "D").Value
    ChDir Yol
        
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")
    
    If Onay = vbYes Then
        S1.ExportAsFixedFormat Type:=xlTypePDF, _
        Filename:=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:red;font-family:Calibri (Gövde);font-size:14.5'><b>" & Mesaj & "</b></font></p>"
        
        With Outlook_Mail
            .Display
            .To = S1.Cells(12, 4)
            .CC = "ilker.topkara@oksanoto.com"
            .BCC = ""
            .Subject = S1.Cells(10, 4)
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya_Adi & ".pdf"
            .BodyFormat = 2
            .Save
            '.Send
        End With
        
        MsgBox "İşleminiz tamamlanmıştır.", vbInformation
    
    Else
        
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
    
    End If
    
    Set S1 = Nothing
    Set Outlook_Mail = Nothing
    Set Outlook_App = Nothing
End Sub

halit3 · 10 Nisan 2015

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.

Kod:

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

wesdesa · 11 Nisan 2015

Tüm emeği geçen herkese çok ama çok teşekkürler fevkalede oldu kod çok sağolun...

wesdesa · 13 Nisan 2015

Korhan Ayhan abi merhaba verdiğin kodu iki ayrı butonda yapmak istesem nasıl olacak acaba bazen direkt mail gönderme olmuyormuş iş yeri söyledi.. Bir butonla pdf kaydetsiz diğer bir butonla mail göndersin sen bir bütün vermiştin ya ama yine aynı kaydettiği dosyayı mail atsın...yardım edermisin lütfen

wesdesa · 14 Nisan 2015

Abilerim şu Korhan abinin verdiği kodda iki ayrı buton yapmam gerekli lütfen yardım edin kod bir bütün halinde dosyayı kaydedip , kaydettiği dosyayı mail atarak çalışıyor ben bunu ayırarak bir butondan dosya kaydı diğer butondan mail gönderme yapmak istiyorum..Teşekkürler

halit3 · 14 Nisan 2015

En baştan kodlarınız ayrı ayrı değilmiydi ?
burada kodlarınız birleştirildi
şimdi de tekrar ayırmak istiyorsunuz.

sizin dosyanızdaki D6 hücresinde tam olarak ne yazıyor. naktasına virgülüne kadar eksiksiz buraya yazabilirmisiniz.

wesdesa · 14 Nisan 2015

abi kodlarım ayrıydı biliyorum fakat birleştirildikten sonra şöyle bir ihtiyaç oldu bazı durumlarda her kayıtlı doya mail atılmıyormuş..Bu yüzden iki ayrı buton istedim ki kaydı ayrı butondan yapayım maili ayrı butondan yapayım.

D6 hücresinde müşteri adı yazıyor değişken "Merkez Komutanlığı"

halit3 · 14 Nisan 2015

Sizin 1 nolu mesajınızdaki kodlarla ilgili bunları denermisiniz.

pdf kayıt için kod

Kod:

Sub PDFKaydet_Click()
dosya_adı = Cells(6, "D").Value [COLOR="Red"]& ".pdf"[/COLOR]
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
MsgBox "işlem tamam!"
End If
If a = vbNo Then
MsgBox "işlemi iptal ettiniz.!"
End If
End Sub

mail için kod

Kod:

Sub Gonder_Click()
Dim OutlookUygulama As Object
Dim Mail As Object

Set OutlookUygulama = New Outlook.Application
Set Mail = OutlookUygulama.CreateItem(0)

[COLOR="red"]dosya_adı = Cells(6, "D").Value & ".pdf"[/COLOR]

With Mail
.To = Cells(12, 4)
.CC = "ilker.topkara@oksanoto.com"
.BCC = ""
.Subject = Cells(10, 4)
.Body = "Merhaba Sayın Yetkili," & vbCrLf & "" & vbCrLf & "İstemiş olduğunuz ürünlere ait fiyat teklifimiz ekte bilgilerinize sunulmuştur.Firmamızdan teklif almak suretiyle" & vbCrLf & "göstermiş olduğunuz ilgiye teşekkür eder, iyi çalışmalar dileriz."
.Attachments.Add ([COLOR="red"]ThisWorkbook.Path & "\" & dosya_adı[/COLOR])
.Send
End With

Set Mail = Nothing
Set OutlookUygulama = Nothing
End Sub

halit3 · 14 Nisan 2015

Alternatif olarak

kod gmail hesabından mail göndermektedir.
Kodu çalıştırınca gelen mesajlara evet veya hayır seçeneklerini seçerek işlem yapın.

açıklama

D6 hücresine dosya adını yazdım (deneme dosya) uzantısız
D10 hücresine konu adını yazdım (merhaba)
D12 hücresine mail göndereceğ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.

kod:

Kod:

Sub mailgönder()

dosya_adı = Cells(6, "D").Value & "[COLOR="red"].pdf[/COLOR]"

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

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

mesaj2 = MsgBox("mail göndermek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

If mesaj2 = vbYes Then

mesaj3 = MsgBox("mail ekinde dosya eklemek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

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

If mesaj3 = vbYes Then
objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
End If

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
End If
MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

wesdesa · 15 Nisan 2015

Abi çok teşekkür ederim...zahmet verdim..

tutisen · 15 Nisan 2015

merhebalar,

ben de bir excel dosyasını otomatik olarak maille göndermek istiyorum. mail göndermeyi paylaşılan kodları inceleyerek az çok çözdüm. fakat benim asıl yapmak istediğim; excel dosyasını her değiştirip kaydettiğimde otomatik olarak mail göndermesi. hatta hangi satırda değişiklik yaptığımı da maile yazdırabilirsem çok daha güzel olur tabi

yardımlarınızı bekliyorum. şimdiden çok teşekkür ederim.

wesdesa · 16 Nisan 2015

Sayın tutisen, benim sıkıntım aynıydı sağolsunlar çözdüler...bu konudaki kodları incelersen sonuca ulaşırsın otomatik olarak dosyadaki değişkenlerin adıyla pdf formatında kaydedip mail gönderiyor..

MrSeker · 11 Mayıs 2015

Merhabalar arkadaşlar;

Elimde bir çalışma kitabı mevcut ve bunun içinde 6 adet çalışma sayfası var sayfaya bir buton eklemek istiyorum kaydet ve gönder diye ama şöyle bir ayrıntı var gönder dediğimde sadece bu sayfalardan 4 adetini göndermesi lazım. ayriyeten sayfamda yazdır ve kaydet butonu mevcut

Kod:

Private Sub CommandButton1_Click()
ActiveWorkbook.Save
Sheets("BİLGİ FORMU").PrintOut
Sheets("SÖZLEŞME").PrintOut
Sheets("AİLE BİLDİRİMİ").PrintOut
Sheets("TAAHÜTNAME").PrintOut
Sheets("MESAİ ONAY BELGESİ").PrintOut
Sheets("ŞUBE BİLGİ").PrintOut
If Range("C7") = "MERKEZ - ŞOFÖR" Then
        Sheets("ŞÖFÖR").PrintOut
    End If
End Sub

buton kodu bu şekilde nasıl bir düzenleme yapmam gerekiyor ? şimdiden herkese teşekkürler.

u.L.a.s · 14 Ağustos 2016

Merhabalar

Bu konuda bir tane pdf dosyasını ekleyip göndermeye ek olarak. ben yolunu belirttiğim klasör altından birden fazla dosyayı mail eki olarak göndermek istiyorum.

"C:\Users\username\Desktop\iptalgonder" diye bir klasörüm var. ben bu klasör içerisine göndereceğim pdf uzantılı bir kaç tane dosya atıyorum.

ve bir makro kodum var onu çalıştırınca bu klasör altında bulunan tüm pdf leri mail eki olarak ekleyip göndermesini istiyorum.

NOT : Bu konu altında sadece bir tane dosya adı belirtilirse gönderebiliyor. birden fazla dosyayı eklesin diye şu şekilde bir ekleme yapıyorum ama ekte hiç bir dosya göndermiyor.

Kod:

.Attachments.Add ("C:\Users\username\Desktop\iptalgonder\*.msg")

u.L.a.s · 14 Ağustos 2016

Sorduğum soruyu aşağıdaki şekilde çözümledim

Kod:

 StrFile = Dir(StrPath & "*.*")
        Do While Len(StrFile) > 0
            .Attachments.Add StrPath & StrFile
            StrFile = Dir
        Loop

staluer · 28 Ekim 2016

halit3' Alıntı:

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.

Kod:

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

Başarılı bir şekilde çalıştı. Ayarları yandex olarak değiştirdiğimde de mail gönderme başarılı oldu.
Teşekkürler.

staluer · 28 Ekim 2016

halit3' Alıntı:

Alternatif olarak

kod gmail hesabından mail göndermektedir.
Kodu çalıştırınca gelen mesajlara evet veya hayır seçeneklerini seçerek işlem yapın.

açıklama

D6 hücresine dosya adını yazdım (deneme dosya) uzantısız
D10 hücresine konu adını yazdım (merhaba)
D12 hücresine mail göndereceğ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.

kod:

Kod:

Sub mailgönder()

dosya_adı = Cells(6, "D").Value & "[COLOR="red"].pdf[/COLOR]"

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

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

mesaj2 = MsgBox("mail göndermek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

If mesaj2 = vbYes Then

mesaj3 = MsgBox("mail ekinde dosya eklemek istiyormusunuz.?", vbYesNo + vbInformation, " Uyarı")

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

If mesaj3 = vbYes Then
objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı
End If

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
End If
MsgBox "işlem tamam.", vbApplicationModal, "Bilgilendirme!"


End Sub

objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı

Bu kısımda hata veriyor. Sebebi ne olabilir?

staluer · 28 Ekim 2016

staluer' Alıntı:
objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı

Bu kısımda hata veriyor. Sebebi ne olabilir?

objEmail.Addattachment ThisWorkbook.Path & "\" & dosya_adı & ".pdf"

bu şekilde düzeltince çalıştı.
uzantıyı algılamıyormuş.

kartalkartal · 2 Kasım 2016

Merhaba Arkadaşlar,
Kodlar gmailde çok güzel çalışıyor fakat bu kodları outlook için ne gibi bir değişiklik yapmamız gerekiyor ,emeği geçen herkese teşekkür ederim,ellerinize sağlık.

iyi çalışmalar.

Makro ile pdf Kaydedilen dosyayı Mail Gönderme

wesdesa

Korhan Ayhan

Administrator

halit3

Uzman

wesdesa

wesdesa

wesdesa

halit3

Uzman

wesdesa

halit3

Uzman

halit3

Uzman

wesdesa

tutisen

wesdesa

MrSeker

u.L.a.s

u.L.a.s

staluer

staluer

staluer

kartalkartal