Makro ile pdf Kaydedilen dosyayı Mail Gönderme

askm · 29 Kasım 2017

Kod:

Dim Outlook_App As Object
Dim Outlook_Mail As Object
Dim S1 As Worksheet, Onay As Byte, Mesaj As String, tttsayisi As String, i As Integer, t As Integer, ttt As String



Sub PDF_KAYDET_MAIL_GONDER()
    On Error Resume Next
    
    tttsayisi = WorksheetFunction.CountA(ActiveSheet.Range("AA:AA")) - 4
    
    i = 4
        
    For t = 1 To tttsayisi
    Set Outlook_App = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    i = i + 1
    
    ttt = Cells(i, 27).Value
    
    Range("AC1").Value = ttt
    
    ActiveSheet.PivotTables("PivotTable1").PivotFields("TTT DESC").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable1").PivotFields("TTT DESC").CurrentPage = Range("AC1").Value
    
    Set S1 = ActiveSheet
    S1.PageSetup.Orientation = xlLandscape
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Cells(i, 27).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 = S1.Cells(5, 26).Value
        '"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
            .To = S1.Cells(i, 28)
            '.CC =  "tamer.karacan@takeda.com"
            .BCC = ""
            .Subject = S1.Cells(i, 27)
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya_Adi & ".pdf"
            .BodyFormat = 2
            .Save
            .Display
            '.Send
        End With
        Set Outlook_Mail = Nothing
        Set Outlook_App = Nothing
    
    
        MsgBox "Gönderim tamamlandi.", vbInformation
    
    Else
        
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        
        Range("AC1").Value = ""
    
    End If
    
    Next
    
    Set S1 = Nothing
'    Set Outlook_Mail = Nothing
'    Set Outlook_App = Nothing
End Sub

teneken · 29 Kasım 2017

bu muymuş yani

çok teşekkürler.

teneken · 29 Kasım 2017

askm' Alıntı:

Kod:

Dim Outlook_App As Object
Dim Outlook_Mail As Object
Dim S1 As Worksheet, Onay As Byte, Mesaj As String, tttsayisi As String, i As Integer, t As Integer, ttt As String



Sub PDF_KAYDET_MAIL_GONDER()
    On Error Resume Next
    
    tttsayisi = WorksheetFunction.CountA(ActiveSheet.Range("AA:AA")) - 4
    
    i = 4
        
    For t = 1 To tttsayisi
    Set Outlook_App = CreateObject("Outlook.Application")
    Set Outlook_Mail = Outlook_App.CreateItem(0)
    i = i + 1
    
    ttt = Cells(i, 27).Value
    
    Range("AC1").Value = ttt
    
    ActiveSheet.PivotTables("PivotTable1").PivotFields("TTT DESC").ClearAllFilters
    ActiveSheet.PivotTables("PivotTable1").PivotFields("TTT DESC").CurrentPage = Range("AC1").Value
    
    Set S1 = ActiveSheet
    S1.PageSetup.Orientation = xlLandscape
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\" & S1.Cells(i, 27).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 = S1.Cells(5, 26).Value
        '"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
            .To = S1.Cells(i, 28)
            '.CC =  "tamer.karacan@takeda.com"
            .BCC = ""
            .Subject = S1.Cells(i, 27)
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya_Adi & ".pdf"
            .BodyFormat = 2
            .Save
            .Display
            '.Send
        End With
        Set Outlook_Mail = Nothing
        Set Outlook_App = Nothing
    
    
        MsgBox "Gönderim tamamlandi.", vbInformation
    
    Else
        
        MsgBox "İşleminiz iptal edilmiştir.", vbInformation
        
        Range("AC1").Value = ""
    
    End If
    
    Next
    
    Set S1 = Nothing
'    Set Outlook_Mail = Nothing
'    Set Outlook_App = Nothing
End Sub

yalnız şimdi denedim de, yine sadece ilk maili gönderiyor, diğerlerini gönderiyormuş gibi yapıyor ama herhangi bir mail gitmiyor.

askm · 29 Kasım 2017

Displayı kapatıp send i açıp deneyebilir misiniz.

teneken · 29 Kasım 2017

askm' Alıntı:
Displayı kapatıp send i açıp deneyebilir misiniz.

send i açmıştım zaten, display i kapatıp tekrar denedim sonuç yine aynı. sadece T1 maili gidiyor diğerleri gidiyormuş gibi yapıyor ama gitmiyor.

askm · 29 Kasım 2017

Aynı kodları ben de denedim tekrardan 3 farklı mail adresi yazdım. 3 farklı mail adresine mail gitti. O mail adreslerine de mail düştü.

teneken · 29 Kasım 2017

o zaman ilginç bir durum var. bende mail adreslerini 3 ayrı adres yazarak denedim. ama sadece ilk adresteki mail gönderildi diğerleri gönderilmedi. ben biraz daha eşeleyeyim bakalım. ilginize çok teşekkürler.

teneken · 30 Kasım 2017

teneken' Alıntı:
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.

merhaba, bu konu ile ilgili benim neden mail atamadığım konusunda yardımcı olabilecek var mı acaba?

teşekkürler

askm · 30 Kasım 2017

Dosyanız ektedir. Deneyin. Bende sorunsuz çalışıyor. Makro güvenlik ayarlarını kontrol edin.

teneken · 30 Kasım 2017

askm' Alıntı:
Dosyanız ektedir. Deneyin. Bende sorunsuz çalışıyor. Makro güvenlik ayarlarını kontrol edin.

merhaba,

valla ne diyim sizin yolladığınız dosya ile çalıştı. komutları ana dosyada uyguladım yine çalıştı. yan yana koyup kontrol ediyorum belirgin bir fark yok

ilginç oldu. ilginize çok teşekkür ederim.

askm · 30 Kasım 2017

Rica ederim. Kolay gelsin.

szrtas · 13 Haziran 2020

Teşekkür ederim. Saatlerdir bu dosyayı arıyordum

furkani · 13 Haziran 2022

Merhabalar,
Aşağıdaki kod gayet güzel çalışıyor. Ancak, mail attıkça Sheets("mail_list").Range("B2:B10") satırlarında yer alan 2 mail adresini önce 1' er kez sonra 2' şer kez sonra 3' er kez diye devam edecek şekilde kime kısmına ekliyor.
Yardım rica ediyorum. Teşekkürler.

Kod:

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 mail()
    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("komisyon_tutanak")
    
    Yol = "C:\Users\furkanipek\Desktop\HAMMADDE ÖZET\Fiyatlandırma Komisyon Kararları\"
    Dosya_Adi = Sheets("komisyon_tutanak").Range("C1") & " - " & Sheets("komisyon_tutanak").Range("J6") & ".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("mail_list").Range("B2:B10").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

ekaya9148 · 24 Ağustos 2022

Merhabalar,

Bir excel dosyam var ve bu dosyayı pdf yapıp ve e-mail olarak gönderiyorum. Fakat dosya ismine bugünün tarihini yazdırdığımda mail geliyor ama ekli dosya gelmiyor. Attachments kısmına yada başka bir yere ne gibi bir komut yazabilirim. Kod aşağıdadır.

Sub CreatePDF()

ThisWorkbook.ExportAsFixedFormat xlTypePDF, Filename:="\\c::\PDF\deneme.pdf" & "_" & Date

Application.Wait (Now + TimeValue("00:00:10"))

Dim OutApp As Object
Dim OutMail As Object
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next

With OutMail
.To = "xxx@yyy.zzz"
.CC = ""
.BCC = ""
.Subject = "xxxx"
.Body = "yyyyı"
.Attachments.Add ("c:\deneme.pdf")
.Send

End With

On Error GoTo 0

Set OutMail = Nothing
Set OutApp = Nothing

End Sub

necati · 24 Ağustos 2022

Merhaba,
Şöyle dener misiniz.

Kod:

ThisWorkbook.ExportAsFixedFormat xlTypePDF, Filename:="c:\PDF\" & "deneme _ " & Date & ".pdf"

necati · 24 Ağustos 2022

Alttaki diğer satırları şimdi farkettim,

Kod:

.Attachments.Add ("c:\deneme.pdf")

satırının da yukarıdaki satıra göre değişmesi gerek. Yani:

Kod:

.Attachments.Add ("c:\PDF\" & "deneme _ " & Date & ".pdf")

ekaya9148 · 24 Ağustos 2022

necati' Alıntı:
Alttaki diğer satırları şimdi farkettim,

Kod:

.Attachments.Add ("c:\deneme.pdf")

satırının da yukarıdaki satıra göre değişmesi gerek. Yani:

Kod:

.Attachments.Add ("c:\PDF\" & "deneme _ " & Date & ".pdf")

Necati hocam çok teşekkür ederim. Kod çalıştı.

Bir sorum daha var bir türlü yapamadım. Bu excel dosyasını açar açmaz iki hücredeki rakamları aynı sheetteki başka bir alana otomatik kopyalatmak istiyorum. Böyle bir şey yapabilirmiyiz?

necati · 24 Ağustos 2022

Modüle yazılacak kod:

Kod:

Sub Auto_Open()
  MsgBox "Merhaba Ekaya9148 G3 ve G4 deki değerler H3 ve H4' e kopyalandı"
  [H3].Value = [G3].Value
  [H4].Value = [G4].Value
End Sub

ekaya9148 · 24 Ağustos 2022

necati' Alıntı:
Modüle yazılacak kod:

Kod:

Sub Auto_Open() MsgBox "Merhaba Ekaya9148 G3 ve G4 deki değerler H3 ve H4' e kopyalandı" [H3].Value = [G3].Value [H4].Value = [G4].Value End Sub

Burda sheet adını belirtmek gerekirmi? Çünkü 5 sheet var çalışma dosyasında.

necati · 24 Ağustos 2022

ekaya9148' Alıntı:
iki hücredeki rakamları aynı sheetteki başka bir alana otomatik kopyalatmak istiyorum. Böyle bir şey yapabilirmiyiz?

Aynı sheet içinde olacağı için gerekmez.

Makro ile pdf Kaydedilen dosyayı Mail Gönderme

askm

Destek Ekibi

teneken

teneken

askm

Destek Ekibi

teneken

askm

Destek Ekibi

teneken

teneken

askm

Destek Ekibi

Ekli dosyalar

teneken

askm

Destek Ekibi

szrtas

furkani

ekaya9148

necati

necati

ekaya9148

necati

ekaya9148

necati