Sayfayı pdf kaydedip mail olarak göndermek

lapot · 31 Ağustos 2016

"I" stununa kadar olan kism listdede olacak , "J" den "Q" kadar olan kismin toplamlarida listenin altina kopyalaniyor ve yukaridaki resimdeki sekil cikiyor.

Korhan Ayhan · 1 Eylül 2016

Aşağıdaki kodu deneyiniz.

Kod:

Sub PDF_KAYDET_MAIL_GONDER()
    Dim S1 As Worksheet, S2 As Worksheet, Kriter As String
    Dim K1 As Workbook, S3 As Worksheet, Son As Long, Yol As String
    Dim Uygulama As Object, Yeni_Mail As Object, Dosya_Adi As String
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Remitance")
    Set S2 = Sheets("Lists")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\Dosya.pdf"
    ChDir Yol
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0
    
    Kriter = S2.Range("B2").Value
    
    S1.Range("A1").AutoFilter 2, Kriter
    Son = S1.Cells(S1.Rows.Count, 1).End(3).Row
    
    Set K1 = Workbooks.Add(1)
    Set S3 = K1.Sheets(1)
    S1.Range("A1:Q" & Son).Copy S3.Range("A1")
    
    With S3.Range("A1:Q" & Son)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideVertical).Weight = xlThick
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
        .Borders(xlInsideVertical).ColorIndex = xlAutomatic
    End With
    
    Son = Son + 3
    S3.Range("J1:Q1").Copy S3.Cells(Son, 2)
    S3.Cells(Son + 1, 2) = "=Sum(J:J)"
    S3.Range("B" & Son + 1 & ":I" & Son + 1).FillRight
    
    With S3.Range("B" & Son & ":I" & Son + 1)
        .Borders(xlEdgeLeft).LineStyle = xlContinuous
        .Borders(xlEdgeTop).LineStyle = xlContinuous
        .Borders(xlEdgeBottom).LineStyle = xlContinuous
        .Borders(xlEdgeRight).LineStyle = xlContinuous
        .Borders(xlInsideVertical).LineStyle = xlContinuous
        .Borders(xlEdgeLeft).Weight = xlThick
        .Borders(xlEdgeTop).Weight = xlThick
        .Borders(xlEdgeBottom).Weight = xlThick
        .Borders(xlEdgeRight).Weight = xlThick
        .Borders(xlInsideVertical).Weight = xlThick
        .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
        .Borders(xlEdgeTop).ColorIndex = xlAutomatic
        .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
        .Borders(xlEdgeRight).ColorIndex = xlAutomatic
        .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
    
    S3.Cells.VerticalAlignment = xlCenter
    S3.Cells.EntireColumn.AutoFit
    
    With S3.PageSetup
        .PrintArea = "$A$1:$I$" & Son + 1
        .LeftMargin = Application.InchesToPoints(0)
        .RightMargin = Application.InchesToPoints(0)
        .TopMargin = Application.InchesToPoints(0)
        .BottomMargin = Application.InchesToPoints(0)
        .HeaderMargin = Application.InchesToPoints(0)
        .FooterMargin = Application.InchesToPoints(0)
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = 1
    End With
    
    S3.Range("A1:I" & Son + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
    Dosya_Adi, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
    IgnorePrintAreas:=False, OpenAfterPublish:=False

    K1.Close 0

    Set Uygulama = CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)

    Mesaj = "Sayın Yetkili,<br><br>" & "Aylık hesap ekstreniz ektedir.<br><br>" & _
            "İnceleyip mutabakat konusunda bilgi vermenizi rica ederim."
    
    Mesaj = "<p style='color:blue;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
    
    With Yeni_Mail
        .Display
        .To = "aaaa@bbbb.com"
        .CC = ""
        .BCC = ""
        .Subject = "Hesap Ekstresi"
        .HTMLBody = Mesaj & .HTMLBody
        .Attachments.Add Dosya_Adi
        .BodyFormat = 2
        .Save
        '.Send
    End With
    
    Application.ScreenUpdating = True

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

lapot · 1 Eylül 2016

cok tesekkurler Korhan arkadasim ama sadece bir musteri kodunu yapiyor, benim listemde onlarca degisik musteri var.her musteri icin ayri ayri liste nasil eklerim?

saygilar sunuyorum

Korhan Ayhan · 1 Eylül 2016

Ben dosyanızın nasıl çalıştığını bilmiyorum. Sizin yönlendirmenize göre kodu revize ediyorum.

Mesajlarınız ne kadar açıklayıcı olursa konuda o kadar çabuk çözüme ulaşacaktır.

Ek olarak önerdiğim PDF kaydetme kodları güncel excel versiyonlarında kullanılabilmektedir. Sizin versiyonunuz "Excel 2000" olarak görünüyor. Eski bir bilgiyse güncellemenizde fayda var.

lapot · 1 Eylül 2016

kusura bakmayin , farkina varmadim ornek dosyada sadece tek tip kod oldugunu, yeni dosya ekledim B stununda degisik kodlar var, onlari gruplastirip PDF nasil yaparim?

Korhan Ayhan · 1 Eylül 2016

Senaryo nasıl işleyecek tarif eder misiniz?

lapot · 2 Eylül 2016

B stunundaki her kodua ait veileri ayri ayri gurup yapıp PDF şeklinde her grubun ayrı email adresi var , ona email yapacak. Yani sizin bu tek kod için yaptığınızı B deki her kod icin yaptırmak amacım. Umarım anlatabildim. Çok teşekkürler ilginize.

Korhan Ayhan · 2 Eylül 2016

Gönderim yapılacak mail adresleri hangi alanda bulunuyor.

lapot · 2 Eylül 2016

sanirim AK stununda, her kodun basliktan sonraki ilk srada AK stununda , yani AK2 de olacak

Korhan Ayhan · 2 Eylül 2016

"Sanırım" derken tablo size ait değil mi?

lapot' Alıntı:
sanirim AK stununda, her kodun basliktan sonraki ilk srada AK stununda , yani AK2 de olacak

lapot · 2 Eylül 2016

Kesin like bana ait. Sadece hangi sutuna denk geleceginden emin degildim, cunku excel query den geliyor datalar biz orayı kabul edersek olur. Daha sonra ben ayarlamasını yaparım. Saygılar sunuyorum Korhan arkadaşim

Korhan Ayhan · 4 Eylül 2016

Aşağıdaki kodu deneyiniz.

Kod:

Sub PDF_KAYDET_MAIL_GONDER()
    Dim S1 As Worksheet, S2 As Worksheet, Kriter As Range, Bul As Range, Mail_Adresi As String
    Dim K1 As Workbook, S3 As Worksheet, Son As Long, Yol As String
    Dim Uygulama As Object, Yeni_Mail As Object, Dosya_Adi As String
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Remitance")
    Set S2 = Sheets("Lists")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\Dosya.pdf"
    ChDir Yol
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    S1.ListObjects("Tablo1").Unlist
    On Error GoTo 0
    
    
    For Each Kriter In S2.Range("B2:B" & S2.Cells(S2.Rows.Count, 2).End(3).Row)
        S1.Range("A1").AutoFilter 2, Kriter.Value
        Set Bul = S1.Range("B:B").Find(Kriter.Value, , , xlWhole)
        If Not Bul Is Nothing Then
            Mail_Adresi = S1.Cells(Bul.Row, "AK").Value
        End If
        
        Set K1 = Workbooks.Add(1)
        Set S3 = K1.Sheets(1)
        S1.Range("A1").CurrentRegion.Copy S3.Range("A1")
        
        Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
        
        With S3.Range("A1:Q" & Son)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThick
            .Borders(xlEdgeTop).Weight = xlThick
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeRight).Weight = xlThick
            .Borders(xlInsideVertical).Weight = xlThick
            .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
            .Borders(xlEdgeTop).ColorIndex = xlAutomatic
            .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        End With
        
        Son = Son + 3
        S3.Range("J1:Q1").Copy S3.Cells(Son, 2)
        S3.Cells(Son + 1, 2) = "=Sum(J:J)"
        S3.Range("B" & Son + 1 & ":I" & Son + 1).FillRight
        
        With S3.Range("B" & Son & ":I" & Son + 1)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlThick
            .Borders(xlEdgeTop).Weight = xlThick
            .Borders(xlEdgeBottom).Weight = xlThick
            .Borders(xlEdgeRight).Weight = xlThick
            .Borders(xlInsideVertical).Weight = xlThick
            .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
            .Borders(xlEdgeTop).ColorIndex = xlAutomatic
            .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        S3.Cells.VerticalAlignment = xlCenter
        S3.Cells.EntireColumn.AutoFit
        S3.Range("A:A").ColumnWidth = 8
        S3.Range("B:C").ColumnWidth = 10
        S3.Range("D:D").ColumnWidth = 12
        S3.Range("E:G").ColumnWidth = 10
        S3.Range("H:H").ColumnWidth = 12
        S3.Range("I:I").ColumnWidth = 15
        S3.Range("J:Q").ColumnWidth = 8

        With S3.PageSetup
            .PrintArea = "$A$1:$I$" & Son + 1
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        
        S3.Range("A1:I" & Son + 1).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Dosya_Adi, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    
        K1.Close 0
    
        Set Uygulama = CreateObject("Outlook.Application")
        Set Yeni_Mail = Uygulama.CreateItem(0)
    
        Mesaj = "Sayın Yetkili,<br><br>" & "Aylık hesap ekstreniz ektedir.<br><br>" & _
                "İnceleyip mutabakat konusunda bilgi vermenizi rica ederim."
        
        Mesaj = "<p style='color:blue;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
        
        With Yeni_Mail
            .Display
            .To = Mail_Adresi
            .CC = ""
            .BCC = ""
            .Subject = "Hesap Ekstresi"
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya_Adi
            .BodyFormat = 2
            .Save
            .Send
        End With
    Next
    
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    S1.ListObjects.Add(xlSrcRange, S1.Range("$A$1:$AK$" & S1.Cells(S1.Rows.Count, 1).End(3).Row), , xlYes).Name = "Tablo1"
    
    Application.ScreenUpdating = True

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

lapot · 5 Eylül 2016

harika calisiyor cok tesekkur ederim Korhan arkadasim fakat 1.resimdeki mesaj cikiyor her defasinda, bunu nasil giderebirlirim cunku yuzlerce musteriye email gidecek , her defasinda bu meseja tik yapmam gerekir bu sekilde.

2. resimdeki formata donusturmek cok ugras istermi?

ayrica 3. resimdeki sayfalari otomatik silebilirmiyiz, yoksa yuzlerce sayfa olusacak?

sayagilar

Korhan Ayhan · 5 Eylül 2016

Bahsettiğiniz uyarı bende oluşmuyor.

Üstteki mesajımda ki kodda küçük revizeler yaptım. Tekrar deneyiniz.

Eğer yine uyarı verirse bilgisayarınıza bağlanıp bakabilirim.

lapot · 5 Eylül 2016

Resimdeki hatayi Verdi ve bu sirayi isaretledi

S1.ListObjects.Add(xlSrcRange, S1.Range("$A$1:$AK$" & S1.Cells(S1.Rows.Count, 1).End(3).Row), , xlYes).Name = "Tablo1"

ayrica iki degisik kodu bir PDF kaydedip iki emaile ayni sayfa olarak ekledi.

Korhan Ayhan · 5 Eylül 2016

Son önerdiğim kodlar bende çalışıyor. Sizde olmamasının sebebini merak ettim.

Müsait olduğunuzda TeamViewer ile bağlanıp bakabilirim.

lapot · 6 Eylül 2016

kendim bu errror'u cozmeye calisacagim, sanmiyorum calistigim bilgisayarima disardan baglanmaya izin verir.

sana sonsuz tesekur ediyorum Korhan arkadas, cok ugrastin

lapot · 6 Eylül 2016

bir onceki kodu tekrar yuklermisiniz, bu kodu calistiramiyorum, bir onceki kod hic olmazsa calisiyordu, bu versiyonda B sutundaki butun kodlari bir sayfaya ekleyip ayri ayri emaillere ekliyor.

lapot · 7 Eylül 2016

Korhan arkadasim kodu bir onceki hale cevirebilirmisin?

tesekkurler

Korhan Ayhan · 9 Eylül 2016

Deneyiniz.

Kod:

Sub PDF_KAYDET_MAIL_GONDER()
    Dim S1 As Worksheet, S2 As Worksheet, Kriter As Range, Bul As Range, Mail_Adresi As String
    Dim K1 As Workbook, S3 As Worksheet, Son As Long, Yol As String, Tablo As ListObject
    Dim Uygulama As Object, Yeni_Mail As Object, Dosya_Adi As String, Alan As Range
    
    Application.ScreenUpdating = False
    
    Set S1 = Sheets("Remitance")
    Set S2 = Sheets("Lists")
    
    Yol = ThisWorkbook.Path
    Dosya_Adi = Yol & "\Dosya.pdf"
    ChDir Yol
    
    On Error Resume Next
    S1.ShowAllData
    S2.ShowAllData
    On Error GoTo 0
    
    Set Tablo = S1.ListObjects(1)
    
    For Each Kriter In S2.Range("B2:B" & S2.Cells(S2.Rows.Count, 2).End(3).Row)
        S1.Range("A1").AutoFilter 2, Kriter.Value
        With Tablo.AutoFilter.Range
            On Error Resume Next
            Set Alan = .SpecialCells(xlCellTypeVisible)
            On Error GoTo 0
        End With
        
        Set Bul = S1.Range("B:B").Find(Kriter.Value, , , xlWhole)
        If Not Bul Is Nothing Then
            Mail_Adresi = S1.Cells(Bul.Row, "AK").Value
        End If
        
        Set K1 = Workbooks.Add(1)
        Set S3 = K1.Sheets(1)
        Alan.Copy S3.Range("A1")
        
        Son = S3.Cells(S3.Rows.Count, 1).End(3).Row
        
        With S3.Range("A1:Q" & Son)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeTop).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlInsideVertical).Weight = xlMedium
            .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
            .Borders(xlEdgeTop).ColorIndex = xlAutomatic
            .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
        End With
        
        Son = Son + 3
        S3.Range("J1:Q1").Copy S3.Cells(Son, 2)
        S3.Cells(Son + 1, 2) = "=Sum(J:J)"
        S3.Range("B" & Son + 1 & ":I" & Son + 1).FillRight
        S3.Range("G" & Son + 3) = "Grang Total Outstanding"
        S3.Range("I" & Son + 3) = "=Sum(B" & Son + 1 & ":I" & Son + 1 & ")"
        S3.Range("G" & Son + 3 & ":I" & Son + 3).HorizontalAlignment = xlCenter
        S3.Range("G" & Son + 3 & ":H" & Son + 3).MergeCells = True
        S3.Range("G" & Son + 3 & ":I" & Son + 3).Borders.LineStyle = xlContinuous
        S3.Range("G" & Son + 3 & ":I" & Son + 3).Borders.Weight = xlMedium
        S3.Range("G" & Son + 3 & ":I" & Son + 3).Font.Bold = True
        S3.Range("G" & Son + 3 & ":I" & Son + 3).Interior.ColorIndex = 6
        
        With S3.Range("B" & Son & ":I" & Son + 1)
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeTop).LineStyle = xlContinuous
            .Borders(xlEdgeBottom).LineStyle = xlContinuous
            .Borders(xlEdgeRight).LineStyle = xlContinuous
            .Borders(xlInsideVertical).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlMedium
            .Borders(xlEdgeTop).Weight = xlMedium
            .Borders(xlEdgeBottom).Weight = xlMedium
            .Borders(xlEdgeRight).Weight = xlMedium
            .Borders(xlInsideVertical).Weight = xlMedium
            .Borders(xlEdgeLeft).ColorIndex = xlAutomatic
            .Borders(xlEdgeTop).ColorIndex = xlAutomatic
            .Borders(xlEdgeBottom).ColorIndex = xlAutomatic
            .Borders(xlEdgeRight).ColorIndex = xlAutomatic
            .Borders(xlInsideVertical).ColorIndex = xlAutomatic
            .HorizontalAlignment = xlCenter
            .VerticalAlignment = xlCenter
        End With
        
        S3.Cells.VerticalAlignment = xlCenter
        S3.Cells.EntireColumn.AutoFit
        S3.Range("A:A").HorizontalAlignment = xlCenter
        S3.Range("A:A").ColumnWidth = 8
        S3.Range("B:C").ColumnWidth = 10
        S3.Range("D:D").ColumnWidth = 12
        S3.Range("E:G").ColumnWidth = 10
        S3.Range("H:H").ColumnWidth = 12
        S3.Range("I:I").ColumnWidth = 15
        S3.Range("J:Q").ColumnWidth = 8

        With S3.PageSetup
            .PrintArea = "$A$1:$I$" & Son + 3
            .LeftMargin = Application.InchesToPoints(0)
            .RightMargin = Application.InchesToPoints(0)
            .TopMargin = Application.InchesToPoints(0)
            .BottomMargin = Application.InchesToPoints(0)
            .HeaderMargin = Application.InchesToPoints(0)
            .FooterMargin = Application.InchesToPoints(0)
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        
        S3.Range("A1:I" & Son + 3).ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        Dosya_Adi, Quality:=xlQualityStandard, IncludeDocProperties:=True, _
        IgnorePrintAreas:=False, OpenAfterPublish:=False
    
        K1.Close 0
    
        Set Uygulama = CreateObject("Outlook.Application")
        Set Yeni_Mail = Uygulama.CreateItem(0)
    
        Mesaj = "Sayın Yetkili,<br><br>" & "Aylık hesap ekstreniz ektedir.<br><br>" & _
                "İnceleyip mutabakat konusunda bilgi vermenizi rica ederim."
        
        Mesaj = "<p style='color:blue;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"
        
        With Yeni_Mail
            .Display
            .To = Mail_Adresi
            .CC = ""
            .BCC = ""
            .Subject = "Hesap Ekstresi"
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya_Adi
            .BodyFormat = 2
            .Save
            .Send
        End With
    Next
    
    
    On Error Resume Next
    S1.ShowAllData
    On Error GoTo 0
    
    Application.ScreenUpdating = True

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

Sayfayı pdf kaydedip mail olarak göndermek

lapot

Korhan Ayhan

Administrator

lapot

Korhan Ayhan

Administrator

lapot

Ekli dosyalar

Korhan Ayhan

Administrator

lapot

Korhan Ayhan

Administrator

lapot

Korhan Ayhan

Administrator

lapot

Korhan Ayhan

Administrator

lapot

Ekli dosyalar

Korhan Ayhan

Administrator

lapot

Ekli dosyalar

Korhan Ayhan

Administrator

lapot

lapot

lapot

Korhan Ayhan

Administrator