DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
Option Explicit
Sub Filtrelenmiş_Verileri_Mail_Gonder()
Dim S1 As Worksheet, Uygulama As Object, Yeni_Mail As Object
Dim Mesaj As String, Son As Long, Tablo As Range, Veri As Range
Set S1 = Sheets("Sheet1")
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")
With S1
On Error Resume Next
.ShowAllData
On Error GoTo 0
.Columns("K:K").Copy .Range("AA1")
.Range("AA1:AA" & .Rows.Count).RemoveDuplicates Columns:=1, Header:=xlYes
For Each Veri In .Range("AA2:AA" & .Cells(.Rows.Count, 1).End(3).Row)
.Range("A1:J" & .Rows.Count).AutoFilter Field:=11, Criteria1:=Veri.Value
Son = .Cells(.Rows.Count, 1).End(3).Row
If Son > 1 Then
On Error Resume Next
Set Tablo = Nothing
Set Tablo = .Range("A1:J" & Son).SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Mesaj = "Merhaba," & "<br><br>" & "Mail gövdesinde görmek istediniz mesajı buraya yazınız." & "<br><br>" & _
"İyi çalışmalar dileriz."
Mesaj = "<p style='color:black;font-family:Arial;font-size:13.5'>" & Mesaj & "</font></p>"
Set Yeni_Mail = Uygulama.CreateItem(0)
With Yeni_Mail
.Display
.To = Veri.Value
.Cc = ""
.Bcc = ""
.Subject = "Mail konusunu buraya yazınız."
.HTMLBody = Mesaj & RangetoHTML(Tablo) & .HTMLBody
.BodyFormat = 2
.Save
'.Send
End With
End If
Next
On Error Resume Next
.ShowAllData
On Error GoTo 0
End With
Set S1 = Nothing
Set Yeni_Mail = Nothing
Set Uygulama = Nothing
MsgBox "İşleminiz tamamlanmıştır.", vbInformation
End Sub
Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2016
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