DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Dim alan As Range
Dim kime, bilgi As String
Private Sub CommandButton1_Click()
kime = ""
For j = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(j) Then
kime = kime & ListBox2.List(j) & ";"
End If
Next j
bilgi = ""
For j = 0 To ListBox3.ListCount - 1
If ListBox3.Selected(j) Then
bilgi = bilgi & ListBox3.List(j) & ";"
End If
Next j
Call mail_gonder
End Sub
Private Sub UserForm_Initialize()
'LİSTBOX 1
ListBox1.ColumnCount = 6
ListBox1.ColumnWidths = "60,150,75,60,60,60"
ListBox1.RowSource = "İMZALAR!A1:F" & Sheets("İMZALAR").[a65536].End(xlUp).Row
'LİSTBOX 2
ListBox2.ColumnCount = 1
ListBox2.ColumnWidths = "150"
ListBox2.RowSource = "MAİLLER!A1:A" & Sheets("MAİLLER").[a65536].End(xlUp).Row
'LİSTBOX 3
ListBox3.ColumnCount = 1
ListBox3.ColumnWidths = "150"
ListBox3.RowSource = "MAİLLER!A1:A" & Sheets("MAİLLER").[a65536].End(xlUp).Row
Application.ScreenUpdating = False
Range("A:F").Select
ActiveWorkbook.Worksheets("İMZALAR").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("İMZALAR").Sort.SortFields.Add Key:=Range("A1"), _
SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("İMZALAR").Sort
.SetRange Range("A:F")
.Header = xlNo
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Range("A1").Select
Application.ScreenUpdating = True
End Sub
Sub mail_gonder()
On Error GoTo mailatma
Set evnout = CreateObject("Outlook.Application")
Set evnmailitem = evnout.CreateItem(0)
Set shimza = Sheets("İMZALAR")
sonsatir = shimza.Cells(Rows.Count, "A").End(3).Row
Set alan = Range("A1:F" & sonsatir)
With evnmailitem
.Subject = "Konu deneme"
.To = kime
.cc = bilgi
'.Attachments.Add maildosya
.Htmlbody = "<br>" & RangetoHTML(alan) & .Htmlbody
.display
'.send
End With
mailatma:
Set evnmailitem = Nothing
Set evnout = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013
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"
'Copy the range and create a new workbook to past the data in
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
'Publish the sheet to a htm file
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
'Read all data from the htm file into RangetoHTML
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=")
'Close TempWB
TempWB.Close savechanges:=False
'Delete the htm file we used in this function
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
))