Yardım pdf yerine excel olarak mail göndermesi

incsoft

Yeni Üye
Katılım
28 Ocak 2019
Mesajlar
137
En iyi yanıt
0
Puanları
18
Yaş
40
Konum
Ankara
Ad Soyad
Ufuk İNCE
Office Versiyon
Office 2019 Professional
Arkadaşlar aşağıdaki macro ile dosyamı pdf olarak sorunsuz şekilde mail gönderiyorum ancak benim istediğim dosyanın orjinal formatında ya da herhangi bir excel formatında göndermesi. Bunu aşaşıdaki macro'yu ne şekilde değiştirerek yapabilirim? Birde formüllü olarak veriler var dosyamda onları da tamamen değer olarak göndermesini istemekteyim.

Teşekkürler..



Sub SAYFALARI_AYRI_AYRI_PDF_KAYDET_MAIL_GONDER()
Dim Yol As String, Dosya_Adi As String, Dosya As Variant, Adres As String
Dim Uygulama As Object, Yeni_Mail As Object, Veri As Range, Say As Byte
Dim Sayfa As Worksheet, S1 As Worksheet, Onay As Byte, Mesaj As String

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("yazma")
Set S2 = Sheets("1")

Yol = ThisWorkbook.Path & Application.PathSeparator
ChDir Yol

Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo, "Uyarı")

If Onay = vbYes Then
On Error GoTo 10
AppActivate Dosya_Adi, True
SendKeys "%{F4}", True
Application.Wait Now + TimeSerial(0, 0, 2)

10 ReDim Dosyalar(1 To 1)

For Each Sayfa In ThisWorkbook.Sheets
Select Case Sayfa.Name
Case "yazma"
Case Else
Dosya_Adi = Format(S2.Range("j1").Value) & "_" & Format(S1.Range("H2").Value, "dd.mm.yyyy") & ".PDF"
Sayfa.ExportAsFixedFormat Type:=xlTypePDF, _
Filename:=Yol & Dosya_Adi, Quality:=xlQualityStandard, _
IncludeDocProperties:=True, IgnorePrintAreas:=False, OpenAfterPublish:=False
Say = Say + 1
ReDim Preserve Dosyalar(1 To Say)
Dosyalar(Say) = Yol & Dosya_Adi
End Select
Next

S1.Select

Mesaj = S1.Range("H13").Value & "<br><br>" & S1.Range("H25").Value & "<br><br>" & S1.Range("H28").Value

Mesaj = "<p style='color:black;font-family:Calibri (Gövde);font-size:14.5'>" & Mesaj & "</font></p>"

With Yeni_Mail
.Display
.To = S1.Range("H4").Value
.CC = S1.Range("H7").Value
.BCC = ""
.Subject = S1.Range("H10").Value
.HTMLBody = Mesaj & .HTMLBody
For Each Dosya In Dosyalar
.Attachments.Add Dosya
Next
.BodyFormat = 2
.Save
'.Send
End With

For Each Dosya In Dosyalar
Kill Dosya
Next

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

MsgBox "İşleminiz iptal edilmiştir.", vbInformation
End If

Set S2 = Nothing
Set Yeni_Mail = Nothing
Set Uygulama = Nothing
End Sub
 
Üst Alt