Makro ile pdf ve HTLM ile Mail atma

[KARTAL133]

Merhaba Arkadaşlar

Aşağıdaki mail ata biliyorum. ancak Sablon1 dekini de PDF olarak göndermek istiyorum.
şimdiden yardımlarınız için teşekkürler

Mail olarak ata biliyorum.






Aşağıdaki mailde PDF olarak göndermek istiyorum.

 

[KARTAL133]

 

[KARTAL133]

yardımcı olacak var mı ?

 

[KARTAL133]

yardımcı olacak var mı ?

 

[Ömer]

Merhaba,

Yanlış anlamış olabilir.
Şablon1 sayfasının Pdf gönderimi için bir örnek. Gönderim bilgilerindeki; adres, bilgi vs.. siz kendinize göre doldurursunuz.

Sub Mail_At()

    Dim OutApp As Object, OutMail As Object, FSO As Object, yol As String, dosya As String

    Set OutApp = CreateObject("Outlook.Application")
    OutApp.Session.Logon
    Set OutMail = OutApp.CreateItem(0)
   
    Set FSO = CreateObject("Scripting.FilesystemObject")
   
    yol = ThisWorkbook.Path
    dosya = yol & "\" & "Payment_Request.pdf"
   
    Sheets("Şablon1").ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
        dosya, Quality:=xlQualityStandard, _
        IncludeDocProperties:=True, IgnorePrintAreas:=False

    On Error Resume Next
    With OutMail
        .To = "aaa@bbb"
        .CC = "ccc@ddd"
        .Subject = "deneme_başlık"
        .Body = "deneme_metin"
        .Attachments.Add dosya
        .Display
        '.Send
    End With
    On Error GoTo 0

    Kill dosya
   
    Set OutMail = Nothing
    Set OutApp = Nothing
   
End Sub

 

[KARTAL133]

Merhaba Hocam

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

Sablon HTLM ile mail kısmına yazıyor. Onla Birlikte Sablon1 PDF olarak mail ekinde gidecek ancak yukarıda belirtiğim gibi içi dolu olacak 500 Satırda ola bilir 2 satırda ola bilir ona göre pdf de çıkması gerekiyor. mailde ne ise pdf o olacak

bilmem anlata bildim mi

 

[Ömer]

500 yada 2 satır olayını neye göre olacağını anlamadım.

Sanırım siz kodlarda;

If kontrol = 6 Then
isim = "payment Request" & Satır & ".pdf"
S6.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & isim, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False
End If

yukarıdaki blokla bahsettiğiniz sayfayı pdf olarak kaydediyorsunuz. Aşağıdaki kırmızı satırı eklerseniz, mail ekine kaydettiğiniz pdf yi eklemiş olursunuz.

With OutMail
.Display
.To = S1.Range("B2").Text
.CC = S1.Range("B4").Text
.BCC = ""
.Subject = S4.Range("A4").Text
.HTMLBody = RangetoHTML(Alan)

.Attachments.Add yol & isim

.Send
End With

.

 

[KARTAL133]

Merhaba Hoca

Sanırım Anlatamadım

mail yazılanın aynısını da forma yazacak yukarıdaki örnekteki gibi

aşağıdaki pfd olacak ekte mail olarak gidecek

 

[KARTAL133]

Merhaba @Ömer Hocam

istediğim gibi aayarlama yaptım ancak Mail gönderme1 pdf olarak mailde ekleme yapamadım.
atladığım bir sey var sanırım rica etsem kontrol ede bilirmisiniz.



Option Explicit

Sub MAIL_GONDER()
Dim S1 As Worksheet, S2 As Worksheet
Dim S3 As Worksheet, S4 As Worksheet
Dim S51 As Worksheet, S11 As Worksheet
Dim S5 As Worksheet, Son As Long, X As Long
Dim Alan As Range, Alan1 As Range, Kontrol As Range, isim As Range, yol As Range, Satir As Long
Dim OutMail As Object, OutApp As Object
Dim oOutlook As Object, Program As Variant

Set S1 = Sheets("Mail Gonderme")
Set S2 = Sheets("Odeme Listesi")
Set S3 = Sheets("Firma Listesi")
Set S4 = Sheets("Ust Yazi")
Set S5 = Sheets("Sablon")
Set S51 = Sheets("Sablon1")
Set S11 = Sheets("Mail Gonderme1")

On Error Resume Next
Set oOutlook = GetObject(, "Outlook.Application")
On Error GoTo 0

If oOutlook Is Nothing Then Program = Shell("OUTLOOK.EXE", 1)

Set OutApp = CreateObject("Outlook.Application")

On Error GoTo Hata

With Application
.ScreenUpdating = False
.EnableEvents = False
End With

Son = S3.Cells(S3.Rows.Count, 2).End(3).Row

For X = 2 To Son
DoEvents
S1.Cells.EntireRow.Hidden = False
S1.Range("B2:E3").ClearContents
S1.Range("A14:I1013").ClearContents
S11.Cells.EntireRow.Hidden = False
S11.Range("B19:M1013").ClearContents

S2.Range("A5:J" & S2.Rows.Count).AutoFilter Field:=2, Criteria1:=S3.Cells(X, 2).Text
If S2.Cells(S2.Rows.Count, 1).End(3).Row > 5 Then
S1.Range("B2:E2").Value = S3.Cells(X, 3).Value
If S3.Cells(X, 5) = 1 Then
S1.Range("B3").Value = S4.Range("A4").Value
S1.Range("A11").Value = S4.Range("A1").Value
S1.Range("A1020").Value = S4.Range("A3").Value
S1.Range("A1021").Value = S4.Range("K4").Value
S4.Range("K12") = S1.Range("E1015")
S4.Range("K13") = S1.Range("E1016")
S4.Range("K55").Copy S1.Range("A1022")
S4.Range("A36:M36").Copy S11.Range("A1022")
S4.Range("A37:M37").Copy S11.Range("A1023")
S4.Range("A38:M38").Copy S11.Range("A1024")
S4.Range("A39:M39").Copy S11.Range("A1025")
S4.Range("A40:M40").Copy S11.Range("A1026")
S4.Range("A41:M41").Copy S11.Range("A1027")
S4.Range("A42:M42").Copy S11.Range("A1028")
S4.Range("A43:M43").Copy S11.Range("A1029")
S4.Range("A44:M44").Copy S11.Range("A1030")
S4.Range("A45:M45").Copy S11.Range("A1031")
S4.Range("K66").Copy S1.Range("A1023")
S4.Range("K77").Copy S1.Range("A1024")
S4.Range("K88").Copy S1.Range("A1025")
S4.Range("K99").Copy S1.Range("A1026")
S1.Range("A1022").Value = S4.Range("K55").Value
S1.Range("A1023").Value = S4.Range("K66").Value
S1.Range("A1024").Value = S4.Range("K77").Value
S1.Range("A1025").Value = S4.Range("K88").Value
S1.Range("A1026").Value = S4.Range("K99").Value
S1.Range("A1022").Value = S4.Range("a36:M36").Value
S1.Range("A1023").Value = S4.Range("A37:M37").Value
S1.Range("A1024").Value = S4.Range("A38:M38").Value
S1.Range("A1025").Value = S4.Range("A39:M39").Value
S1.Range("A1026").Value = S4.Range("A40:M40").Value
S1.Range("A1027").Value = S4.Range("A41:M41").Value
S1.Range("A1028").Value = S4.Range("A42:M42").Value
S1.Range("A1029").Value = S4.Range("A43:M43").Value
S1.Range("A1030").Value = S4.Range("A44:M44").Value
S1.Range("A1031").Value = S4.Range("A45:M45").Value


S4.Range("A6:I6").Copy S1.Range("A13")
ElseIf S3.Cells(X, 5) = 2 Then
S1.Range("B3").Value = "PAYMENT INFO"
S1.Range("A11").Value = S4.Range("A2").Value
S4.Range("A7:I7").Copy S1.Range("A13")
End If

S2.Range("A6:I" & S2.Cells(S2.Rows.Count, 1).End(3).Row).Copy
S1.Range("A14").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S1.Range("A14:A1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True



S2.Range("d6:d" & S2.Cells(S2.Rows.Count, 4).End(3).Row).Copy ' tarih
S11.Range("b19").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S11.Range("b19:b1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
S2.Range("c6:c" & S2.Cells(S2.Rows.Count, 3).End(3).Row).Copy ' fat.no
S11.Range("d19").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S11.Range("d19:d1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
S2.Range("b6:b" & S2.Cells(S2.Rows.Count, 2).End(3).Row).Copy ' firma adı"
S11.Range("e19").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S11.Range("e19:e1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
S2.Range("g6:g" & S2.Cells(S2.Rows.Count, 7).End(3).Row).Copy ' cinsi
S11.Range("m19").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S11.Range("m19:m1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True
S2.Range("h6:h" & S2.Cells(S2.Rows.Count, 8).End(3).Row).Copy ' tutar
S11.Range("l19").PasteSpecial xlPasteValues
Application.CutCopyMode = False
S11.Range("l19:l1013").SpecialCells(xlCellTypeBlanks).EntireRow.Hidden = True


Set Alan = S1.Range("A11:I1026").SpecialCells(xlCellTypeVisible)
Set Alan1 = S11.Range("A11:M1026").SpecialCells(xlCellTypeVisible)

Alan.Copy S5.Range("B2")
S5.Select
S5.Cells.EntireColumn.AutoFit
Satir = S5.Cells(S5.Rows.Count, 2).End(3).Row
S5.Range("B" & Satir & ":J" & Satir).Borders(xlBottom).LineStyle = xlDouble
S5.Rows(2).RowHeight = 100
S5.Columns(1).ColumnWidth = 2
S5.Columns(11).ColumnWidth = 2

Satir = S5.Cells(S5.Rows.Count, 5).End(3).Row + 1
Set Alan = S5.Range("A1:K" & Satir)

S5.Range("A1").Select

Alan1.Copy S51.Range("B2")
S51.Select
S51.Cells.EntireColumn.AutoFit
Satir = S51.Cells(S51.Rows.Count, 2).End(3).Row
S51.Range("B" & Satir & ":N" & Satir).Borders(xlBottom).LineStyle = xlDouble
S51.Rows(2).RowHeight = 2
S51.Columns(1).ColumnWidth = 2
S51.Columns(11).ColumnWidth = 2

Satir = S51.Cells(S5.Rows.Count, 5).End(3).Row + 1
Set Alan1 = S51.Range("A11:N" & Satir)

S51.Range("A1").Select




isim = "Payment Request Form" & ".pdf"
S11.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & isim, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False






On Error Resume Next

Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
.To = S1.Range("B2").Text
.CC = S1.Range("B4").Text
.BCC = ""
.Subject = S4.Range("A4").Text
.HTMLBody = RangetoHTML(Alan)
.attachments.Add yol & Alan1
.Send
End With

S3.Cells(X, 4) = "GÖNDERİLDİ"
S5.Cells.Delete
S2.ShowAllData
On Error GoTo 0
End If
Next

S1.Cells.EntireRow.Hidden = False

Hata:
With Application
.ScreenUpdating = True
.EnableEvents = True
End With

S1.Select
S1.Range("A10").Select

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

 

[Ömer]

Örneğinizin son halini ekler misiniz.

 

[KARTAL133]

Merhaba @Ömer Hocam

örnek ektedir.

Yardımlarınızı için şimdiden çok teşekkürler

 

[Ömer]

Merhaba

Şuan deneme imkanım yok. Yarın işyerinde deneyip tekrar inceleyeceğim.
Yalnız ilk gördüğüm eksik v hata;

isim = "Payment Request Form" & ".pdf"
S11.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & isim, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

yazmışsınız fakat "yol" adında bir tanımlama göremedim.

Ayrıca; yol ve isim 'i range olarak tanımlamışsınız, String olması gerekir.

Aşağıdaki değişiklik ve ilaveyi yaparak deneyiniz.

isim As Range, yol As Range

yerine aşağıdaki gibi düzeltin.

isim As String, yol As String

ve aşağıdaki gibi yol tanımını ekleyin. Ben dosyayla aynı yolu verdim.

yol = ThisWorkbook.Path & "\"
isim = "Payment Request Form" & ".pdf"
S11.ExportAsFixedFormat Type:=xlTypePDF, Filename:= _
yol & isim, Quality:=xlQualityStandard, IncludeDocProperties:=True, IgnorePrintAreas:=False, _
OpenAfterPublish:=False

.

 

[KARTAL133]

iyi Geceler @Ömer Hoca

Çok teşekkürler elinize sağlık