Excel olarak mail atıyor PDF nasıl yaparım

[atillaciftci]

Aşağıdaki kod süper işime yarıyor sayfayı alıp mail olarak atıyor ama excel olarak atıyor bunun PDF olarak atmasını istiyorum aşağıdaki kodları nasıl değiştiririm.. Herkeze kolay gelsin..


Sub WorkOrder_Mail_Gönder()

Dim FileExtStr As String, FileFormatNum As Long, Sourcewb As Workbook
Dim Destwb As Workbook, TempFilePath As String, TempFileName As String
Dim OutApp As Object, OutMail As Object, sat As Long, i As Long
Dim j As Integer, kime As String

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

Sheets("İş Listesi").Select
' Sheets("Work Order").Range("L2:M" & Rows.Count).ClearContents

sat = 2
For i = 18 To Cells(Rows.Count, "E").End(xlUp).Row
If Cells(i, "B") = "EVET" Then
Range("D" & i & ":M" & i).Copy Sheets("Work Order").Range("L2")
kime = Cells(i, "N")

Sheets("Work Order").Select

Set Sourcewb = ActiveWorkbook

ActiveSheet.Copy
Set Destwb = ActiveWorkbook
With Destwb
If Val(Application.Version) < 12 Then
FileExtStr = ".xls": FileFormatNum = -4143
Else
If Sourcewb.Name = .Name Then
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
MsgBox "Your answer is NO in the security dialog"
Exit Sub
Else
Select Case Sourcewb.FileFormat
Case 51: FileExtStr = ".xlsx": FileFormatNum = 51
Case 52:
If .HasVBProject Then
FileExtStr = ".xlsm": FileFormatNum = 52
Else
FileExtStr = ".xlsx": FileFormatNum = 51
End If
Case 56: FileExtStr = ".xls": FileFormatNum = 56
Case Else: FileExtStr = ".xlsb": FileFormatNum = 50
End Select
End If
End If
End With

TempFilePath = Environ$("temp") & "\"
TempFileName = Sourcewb.Name & " " & Format(Now, "dd-mmm-yy h-mm-ss")

Set OutApp = CreateObject("Outlook.Application")
OutApp.Session.Logon
Set OutMail = OutApp.CreateItem(0)

With Destwb
.SaveAs TempFilePath & TempFileName & FileExtStr, FileFormat:=FileFormatNum
On Error Resume Next
With OutMail
.To = kime
.cc = "aaa@a.com;bbb@b.com"
.BCC = ""
.Subject = "Email konusu"
.Body = "Bu maili EXCEL otomatik göndermiştir."
.Attachments.Add Destwb.FullName
.Display '.Send
End With
On Error GoTo 0
.Close SaveChanges:=False
End With
Kill TempFilePath & TempFileName & FileExtStr

Set OutMail = Nothing
Set OutApp = Nothing

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

End If
Sheets("İş Listesi").Select
Next i

End Sub