Soru pdf yerine excel formatında göndermesi

I

incsoft

Altın Üye
Katılım
18 Ağustos 2009
Mesajlar
730
Excel Vers. ve Dili
Office Ev ve İş 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
12-12-2024
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
 
Korhan Ayhan

Korhan Ayhan

Administrator
Yönetici
Admin
Katılım
15 Mart 2005
Mesajlar
42,160
Excel Vers. ve Dili
Microsoft 365 Tr-En 64 Bit
Deneyiniz.

C++: 
Option Explicit

Sub Send_File_Mail()
    Dim Yol As String, Yedek As String, Dosya As String
    Dim Uygulama As Object, Yeni_Mail As Object
    Dim FSO As Object, Sayfa As Worksheet
    Dim 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 = VBA.CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
    
    Set S1 = Sheets("yazma")
 
    Yol = ThisWorkbook.Path & Application.PathSeparator
    Yedek = Yol & "Rapor.xlsm"
    Dosya = Yol & "Rapor"
    
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo + vbDefaultButton2, "Uyarı")
    
    If Onay = vbYes Then
        ThisWorkbook.Save
        
        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>"
        
        Call FSO.CopyFile(ThisWorkbook.FullName, Yedek, True)
        Application.ScreenUpdating = False
        Workbooks.Open Yedek, False, False
           
        For Each Sayfa In ActiveWorkbook.Sheets
            Sayfa.Select
            Sayfa.Cells.Copy
            Sayfa.Cells.PasteSpecial xlValues
            Range("A1").Select
        Next
                
        Sheets(1).Select
        
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Dosya, 51, Local:=True
        ActiveWorkbook.Close 0
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
        
        With Yeni_Mail
            .Display
            .To = S1.Range("H4").Value
            .CC = S1.Range("H7").Value
            .BCC = ""
            .Subject = S1.Range("H10").Value
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya & ".xlsx"
            .BodyFormat = 2
            .Save
            '.Send
        End With
        
        Kill Dosya & ".xlsx"
        Kill Yedek
        
        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
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
End Sub
 
I

incsoft

Altın Üye
Katılım
18 Ağustos 2009
Mesajlar
730
Excel Vers. ve Dili
Office Ev ve İş 2021 - Türkçe
Altın Üyelik Bitiş Tarihi
12-12-2024
Korhan Ayhan' Alıntı:
Deneyiniz.

C++: 
Option Explicit

Sub Send_File_Mail()
    Dim Yol As String, Yedek As String, Dosya As String
    Dim Uygulama As Object, Yeni_Mail As Object
    Dim FSO As Object, Sayfa As Worksheet
    Dim 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 = VBA.CreateObject("Outlook.Application")
    Set Yeni_Mail = Uygulama.CreateItem(0)
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
   
    Set S1 = Sheets("yazma")

    Yol = ThisWorkbook.Path & Application.PathSeparator
    Yedek = Yol & "Rapor.xlsm"
    Dosya = Yol & "Rapor"
   
    Onay = MsgBox("Kayıt edip mail göndermek istiyor musunuz?", vbExclamation + vbYesNo + vbDefaultButton2, "Uyarı")
   
    If Onay = vbYes Then
        ThisWorkbook.Save
       
        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>"
       
        Call FSO.CopyFile(ThisWorkbook.FullName, Yedek, True)
        Application.ScreenUpdating = False
        Workbooks.Open Yedek, False, False
          
        For Each Sayfa In ActiveWorkbook.Sheets
            Sayfa.Select
            Sayfa.Cells.Copy
            Sayfa.Cells.PasteSpecial xlValues
            Range("A1").Select
        Next
               
        Sheets(1).Select
       
        Application.DisplayAlerts = False
        ActiveWorkbook.SaveAs Dosya, 51, Local:=True
        ActiveWorkbook.Close 0
        Application.DisplayAlerts = True
        Application.ScreenUpdating = True
       
        With Yeni_Mail
            .Display
            .To = S1.Range("H4").Value
            .CC = S1.Range("H7").Value
            .BCC = ""
            .Subject = S1.Range("H10").Value
            .HTMLBody = Mesaj & .HTMLBody
            .Attachments.Add Dosya & ".xlsx"
            .BodyFormat = 2
            .Save
            '.Send
        End With
       
        Kill Dosya & ".xlsx"
        Kill Yedek
       
        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
    Set FSO = VBA.CreateObject("Scripting.FileSystemObject")
End Sub
Genişletmek için tıkla ...



Hocam öncelikle teşekkürler ancak normal size göndermiş olduğum ve o kodda size aitti sanırım üzerinde değişiklikler yaparak belli bir yerden ismi aldırarak dosya ismi olarak kaydettirdiğim kodlar filan vardı onlar iptal olmuş sanırım. Benim verilerim dosyada bulunan 1 numaralı sayfada ve ben sadece 1 numaralı sayfayı kaydetmesini istiyorum ve sayfadaki tüm formülleri değere dönüştürerek kaydederek mail olarak atmasını istiyorum. Eğer uygun görürseniz dosyayı da gönderebilirim?

Şimdiden teşekkürler..
 
Cevap yazmak için giriş yap yada kayıt ol.
Üst