Soru E Posta Ile Gönder'e istediğimiz sayfayı ek yapma

Katılım
7 Ekim 2021
Mesajlar
55
Excel Vers. ve Dili
2016 Türkçe
Merhabalar, excelde dosya kısmından şeridi özelleştir kısmından E Posta ile Gönder kısa yolunu aktif ettim ve makroyla kod satırının ne olduğunu buldum. Bu kodu Vba kısmına yazıp çalıştırınca varolan dosyayı ek yapacak şekilde outlook ekranını aciyor fakat ben calisma kitabını değilde çalışma kitabi icerisinden istediğim sayfayi yazdirmak istiyorum. Bununla ilgili kodu nasil olusturabilirim? Yardımcı olabilirseniz sevinirim.
Iyi akşamlar dilerim.
 
Katılım
24 Nisan 2005
Mesajlar
3,473
Excel Vers. ve Dili
Office 2016 EN 64 Bit
Arşivden buldum. İnceleyebilirsiniz.
Aktif sayfa yada seçilen sayfa olarak bu satırları kullanabilirsiniz.

Set rng = ActiveSheet.UsedRange
'Set rng = Sheets("Sayfaadı").UsedRange

C#:
Option Explicit
Sub Aktif_Sayfayi_Mesaj_Govdesi_Olarak_Gonder()
' Office 2000-2016 sürümlerinde çalışır
    Dim rng As Range
    Dim OutApp As Object
    Dim OutMail As Object
    With Application
        .EnableEvents = False
        .ScreenUpdating = False
    End With
    Set rng = Nothing
    Set rng = ActiveSheet.UsedRange
    'Set rng = Sheets("Sayfaadı").UsedRange
    Set OutApp = CreateObject("Outlook.Application")
    Set OutMail = OutApp.CreateItem(0)
    On Error Resume Next
    With OutMail
        .To = ""
        .CC = ""
        .BCC = ""
        .Subject = ""
        .HTMLBody = RangetoHTML(rng)
        .Display   'göndermek için .Send
    End With
    On Error GoTo 0
    With Application
        .EnableEvents = True
        .ScreenUpdating = True
    End With
    Set OutMail = Nothing: Set OutApp = Nothing
End Sub
------------------------------------------------------------------------------------
Option Explicit
Function RangetoHTML(rng As Range)
    'Office 2000-2016 sürümlerinde çalışır
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
     TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"
    'Kopya aralığı ve geçmiş verileri yeni bir çalışma kitabı oluşturamazsınız
    rng.Copy
    Set TempWB = Workbooks.Add(1)
    With TempWB.Sheets(1)
        .Cells(1).PasteSpecial Paste:=8
        .Cells(1).PasteSpecial xlPasteValues, , False, False
        .Cells(1).PasteSpecial xlPasteFormats, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
    End With
    With TempWB.PublishObjects.Add( _
         SourceType:=xlSourceRange, _
         Filename:=TempFile, _
         Sheet:=TempWB.Sheets(1).Name, _
         Source:=TempWB.Sheets(1).UsedRange.Address, _
         HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    'RangetoHTML içine htm dosyası olan tüm verileri oku
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set ts = fso.GetFile(TempFile).OpenAsTextStream(1, -2)
    RangetoHTML = ts.readall
    ts.Close
    RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                          "align=left x:publishsource=")
     'TempWB'yi kapat
    TempWB.Close savechanges:=False
    'htm dosyası olan bu fonksiyonu sil
    Kill TempFile
    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing
End Function
 
Katılım
7 Ekim 2021
Mesajlar
55
Excel Vers. ve Dili
2016 Türkçe
Kod:
Private Sub CheckBoxEPOSTAGONDER_Click()

If CheckBoxEPOSTAGONDER.Value = True Then

    On Error Resume Next
    Dim File_Name  As String, My_Folder As Variant, X As Long
    Dim My_Sheet As Worksheet, My_Check As Boolean, My_Count As Byte
    Dim My_Box As Object, My_Area As Range, Last_Row As Long
    
        Sheets.Add after:=Worksheets(Worksheets.Count)
        ActiveSheet.Name = "FİLTRELEME"
        
        Set My_Sheet = Sheets("FİLTRELEME")
        
        With My_Sheet
            .Cells.ClearContents
                Last_Row = .Cells(.Rows.Count, 1).End(3).Row + 1
                
                .Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount) = FILTRELEME.ListBox1.List
                .Cells(Last_Row, 1).Resize(FILTRELEME.ListBox1.ListCount, FILTRELEME.ListBox1.ColumnCount).Borders.LineStyle = 1
            
            Application.PrintCommunication = False
            With ActiveSheet.PageSetup
                .LeftHeader = ""
                .CenterHeader = ""
                .RightHeader = ""
                .LeftFooter = ""
                .CenterFooter = ""
                .RightFooter = ""
                .LeftMargin = Application.InchesToPoints(0)
                .RightMargin = Application.InchesToPoints(0)
                .TopMargin = Application.InchesToPoints(0)
                .BottomMargin = Application.InchesToPoints(0)
                .HeaderMargin = Application.InchesToPoints(0)
                .FooterMargin = Application.InchesToPoints(0)
                .PrintHeadings = False
                .PrintGridlines = False
                .PrintComments = xlPrintNoComments
                .PrintQuality = 600
                .CenterHorizontally = True
                .CenterVertically = False
                .Orientation = xlLandscape
                .Draft = False
                .PaperSize = xlPaperA4
                .FirstPageNumber = xlAutomatic
                .Order = xlDownThenOver
                .BlackAndWhite = False
                .Zoom = False
                .FitToPagesWide = 1
                .FitToPagesTall = 1000
                .PrintErrors = xlPrintErrorsDisplayed
                .OddAndEvenPagesHeaderFooter = False
                .DifferentFirstPageHeaderFooter = False
                .ScaleWithDocHeaderFooter = True
                .AlignMarginsHeaderFooter = True
                .EvenPage.LeftHeader.text = ""
                .EvenPage.CenterHeader.text = ""
                .EvenPage.RightHeader.text = ""
                .EvenPage.LeftFooter.text = ""
                .EvenPage.CenterFooter.text = ""
                .EvenPage.RightFooter.text = ""
                .FirstPage.LeftHeader.text = ""
                .FirstPage.CenterHeader.text = ""
                .FirstPage.RightHeader.text = ""
                .FirstPage.LeftFooter.text = ""
                .FirstPage.CenterFooter.text = ""
                .FirstPage.RightFooter.text = ""
            End With
            Application.PrintCommunication = True
            
            .Range("A1:Q1").MergeCells = True
            
            .Cells.Font.Name = "Times New Roman"
            .Cells.Font.Size = 12
            .Range("A1:Q1").Cells.Font.Size = 18
            .Cells.VerticalAlignment = xlCenter
            .Cells.HorizontalAlignment = xlCenter
            .Cells.WrapText = True
            .Range("A1:A2").EntireRow.Font.Bold = True
            .Range("A:B").ColumnWidth = 50
            .Range("C:E").ColumnWidth = 22
            .Range("F:H").ColumnWidth = 12
            .Range("I:I").ColumnWidth = 15
            .Range("J:K").ColumnWidth = 100
            .Range("L:L").ColumnWidth = 60
            .Range("M:M").ColumnWidth = 13
            .Range("N:O").ColumnWidth = 80
            .Range("P:P").ColumnWidth = 25
            .Range("Q:Q").ColumnWidth = 13
            .Columns.AutoFit
            .Rows.AutoFit

            
            For Each My_Box In Me.Controls
                If TypeName(My_Box) = "CheckBox" Then
                    If My_Box.Value = False And My_Box.Caption <> "TÜMÜNÜ SEÇ" Then
                        If My_Area Is Nothing Then
                            Set My_Area = .Cells(1, Val(Replace(My_Box.Name, "CheckBox", "")))
                        Else
                            Set My_Area = Union(My_Area, .Cells(1, Val(Replace(My_Box.Name, "CheckBox", ""))))
                        End If
                    End If
                End If
            Next
                
            If Not My_Area Is Nothing Then My_Area.EntireColumn.Delete
        End With
        
Application.Dialogs(xlDialogSendMail).Show


End If
End Sub

Hocam kodum bu ve en sonda
Application.Dialogs(xlDialogSendMail).Show ile outlook ekranının açılmasını sağladım ama ek olarak bu oluşturduğum FİLTRELEME sayfasının eklenmesini istiyorum. Lakin o değil de direk çalıştığım çalışma kitabı ek olarak geliyor.
Bunu nasıl ayarlayabilirim acaba?
 
Üst