Seçilen Hücreleri Mail Göndermek.

[ibozdag2001]

Sub SECILI_ALANI_MAIL_GONDER()

'For Tips see: http://www.rondebruin.nl/win/winmail/Outlook/tips.htm
'Don't forget to copy the function RangetoHTML in the module.
'Working in Excel 2000-2016
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object

Set rng = Nothing
On Error Resume Next
'Only the visible cells in the selection
Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a fixed range if you want
'Set rng = Sheets("YourSheet").Range("D412").SpecialCells(xlCellTypeVisible)
On Error GoTo 0

If rng Is Nothing Then
MsgBox "The selection is not a range or the sheet is protected" & _
vbNewLine & "please correct and try again.", vbOKOnly
Exit Sub
End If

With Application
.EnableEvents = False
.ScreenUpdating = False
End With

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

On Error Resume Next
With OutMail
.To = ""
.CC = "XXX@XXX.com"
.BCC = ""
.Subject = "AÇIKLAMA "
imza = "<H3><B>AÇIKLAMA</B></H3>" & _
"Tel:0212 XXX XX XX<br>" & _
"MAIL ADRESI<br>" & _
"<A HREF=""</A>" & _
"<br><br><B>Saygilarimla Iyi çalismalar.</B>"
.HTMLBody = imza & "<br>" & .HTMLBody
.HTMLBody = RangetoHTML(rng) & .HTMLBody
.Display
End With
On Error GoTo 0

With Application
.EnableEvents = True
.ScreenUpdating = True
End With

Set OutMail = Nothing
Set OutApp = Nothing
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 xublishsource=", _
"align=left xublishsource=")

'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

 

[jethroo]

Merhaba,

Bu liste benim istediğim şeye bir hayli yakın; fakat ben 2 satır seçilirse o iki satırı da göstersin istiyorum. ya da başka bir deyişle filtrelediğim alanların direkt olarak maile eklenmesini istiyorum. Bunu nasıl yapabilirim?

 

[jethroo]

Ayrıca mail adresini ve konusunu da yine filtrelediğim tablodan dinamik olarak alsın istiyorum. Bilgisi olan var mı?

 

[jethroo]

…

 

[TiOr]

@Korhan Ayhan Hocam Merhaba,
Yukarıdaki konulardan ilham alarak aşağıdaki kodu kendi projeme uygulamadım. Seçili olan alanı Outlook'ta açıyor yani iş görüyor fakat size sormak istediğim konu ise alan seçmeden dolu olan hücreleri kendisi otomatik seçmesi için nasıl bir yol izlemem lazım?

>>>Set rng = Union(ActiveSheet.Range("A1:AC1"), mailRng) bu kısımda seçim yapılabiliyor.

Seçim yapmadan nasıl bir şekilde dolu hücrelerin Outlook'a gelmesini sağlayabilirim.
Destek verebilir iseniz çok sevinirim. Saatlerce süren işlemleri çok kısa bir sürede halledebiliyor olacağım için çok kritik bir kod açıkcası
Teşekkürler, iyi çalışmalar.
Syg..

Private Sub CommandButton1_Click()

'http://msdn.microsoft.com/en-us/lib...odeltoSendMailPart2_MailingRangeSelectionBody
' You need to use this module with the RangetoHTML subroutine.
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
Dim rng As Range, mailRng As Range
Dim OutApp As Object
Dim OutMail As Object
Dim adres As String
Set rng = Nothing
On Error Resume Next
'Only send the visible cells in the selection.
'Set rng = Selection.SpecialCells(xlCellTypeVisible)
'You can also use a range with the following statement.
'Set rng = Sheets("YourSheet").Range("D4:D12").SpecialCells(xlCellTypeVisible)
On Error GoTo 0
Set mailRng = Range(Cells(ActiveCell.Row, 1), Cells(ActiveCell.Row, 17))
Set rng = Union(ActiveSheet.Range("A1:AC1"), mailRng)
If rng Is Nothing Then
MsgBox "Seçilen hücreler ""aralık"" değil veya sayfa koruması var. " & _
vbNewLine & "Düzeltip yeniden deneyin.", vbOKOnly
Exit Sub
End If
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
Body = "Merhaba," & "<br>" & "Siparişiniz aşağıdaki gibidir." & RangetoHTML(rng)
With OutMail
.Display
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = Body & "<br>" & .HTMLBody
.Display 'email'i sadece görüntüler. gönder butonuna basarak gönderiniz.
'.Send 'email'i gönderir. ancak güvenlik uyarısı mesajı gelir. onaylayarak devam edilir.
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
End Sub
Function RangetoHTML(rng As Range)
' Works in Excel 2000, Excel 2002, Excel 2003, Excel 2007, Excel 2010, Outlook 2000, Outlook 2002, Outlook 2003, Outlook 2007, and Outlook 2010.
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 workbook to receive the data.
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 an .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 the RangetoHTML subroutine.
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.
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function

 

[Korhan Ayhan]

Forumda CurrentRegion ifadesi ile arama yaparsanız örnek kodlara ulaşabilirsiniz.

 

[TiOr]

@Korhan Ayhan Hocam Merhaba,
CurrentRegion bu konuyla ilgili 10 sayfa konu var hepsini tek tek kontrol ettim. Yukarıda ki konuya istinaden seçim yapmadan dolu olan hücreleri mail gönderme ile ilgili bir konu bulamadım. Bir konu var ondada filitre ile mail gönderme gibi bir konuyu içeriyor. Baya bir zaman geçmiş konu ve konuların üstünden. Konunun da güncel kalabilmesi adına yukardaki kodlar ile bir revize yaparak paylaşmanız mümkünmü Sizden rica ediyorum teşekkürler.

Syg..

 

[Korhan Ayhan]

Kullandığınız tablonuzla ilintili olarak değişkenlik göstereceği için ben standart bir excel tablosuna göre örnek veriyorum.

Set rng = Range("A1").CurrentRegion

 

[TiOr]

@Korhan Ayhan Hocam Selam,
İşlem tamamdır, çok teşekkür ederim.
Hayırlı akşamlar dilerim.
Syg..