DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
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 FunctionPrivate 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