Excelde Mail Gönderimi

[asdasdasd123]

Merhaba,

Excelde otomatik mail gönderimi sağlamak istiyorum. Lakin Mail Gönderiminde ;

1.) Belirli Bir Body Mesajı istiyorum. Örneğin ;

Merhaba,

Alt kısımda yer alan tabloda veriler yer almaktadır.

İyi çalışmalar.

2.) Excelde belirli hücreleri alarak bu maille tablo olarak otomatik eklemek istiyorum.

3.) Mailde Outlook'un kendi mail adresini kullanmak istiyorum.

3 ünü aynı anda yazmayı bir türlü beceremedim. Desteklerinizi bekliyorum.

Kullandığım Kod ;

'***** Mail Gönderim *****
Private Sub CommandButton1_Click()
'*************************** TANIMLAMALAR *********************'
Dim FileExtStr As String
Dim FileFormatNum As Long
Dim Sourcewb, Destwb As Workbook
Dim TempFilePath, TempFileName As String
Dim Sa, sa1, Sa2 As String ' 1.ci Devir
Dim Body, Body1, Body2, signature, HTMLBody, mailToAddress, mailCCAddress As String
Dim OutApp, OutMail, wordDoc As Object
Dim sh As Worksheet
'*************************** TANIMLAMALAR *********************'
With Application
.ScreenUpdating = False
.EnableEvents = False
End With
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Display
End With
mailCCAddress = ""
mailToAddress = ""
'-------------------------'Tanımlama'-------------------------'
'***** Mail Başlığı ***** 1.Devir '
Sa = Cells(13, "K")
sa1 = Format(Range("L13").Value, "hh:mm")
Sa2 = Cells(13, "I")
'-------------------------'Tanımlama'-------------------------'
'***** Mail Ön Yüz *****'
Body = "Merhaba,"
Body1 = "Tabloda Detayları Yer Alan Misafirimize Geri Dönüş Sağlamanı ve Sonucunu Tarafımıza Paylaşmanı Rica ederim."
Body2 = "Desteğin için Teşekkürler, İyi çalışmalar dilerim."
On Error Resume Next
signature = Chr(13) & Chr(13) & OutMail.HTMLBody
On Error Resume Next
With Destwb
'-------------------------'Mail Başlangıç'-------------------------'
Set sh = ThisWorkbook.Worksheets("INDEX")
With sh
.Range("H12:M13").CurrentRegion.Copy
End With
On Error Resume Next
With OutMail
ActiveSheet.Range("H12:M13").Select
ActiveWorkbook.EnvelopeVisible = True
With ActiveSheet.MailEnvelope

End With
.To = ""
.CC = "aktur@hotmail.com"
.BCC = ""
'Set wordDoc = .GetInspector.WordEditor
'wordDoc.Range.PasteExcelTable LinkedToExcel:=False, WordFormatting:=False, RTF:=False
.Subject = Sa & " // " & sa1 & " | " & Sa2
'.Introduction = Body & Body1 & Body2 & signature
.HTMLBody = Body & Chr(12) & Chr(12) & Body1 & Chr(12) & Chr(12) & Body2 & Chr(12) & Chr(12) & signature
.Item.Display
End With
On Error GoTo 0
Set OutMail = Nothing
Set OutApp = Nothing
With Application
.ScreenUpdating = True
.EnableEvents = True
End With
ActiveWorkbook.EnvelopeVisible = False
'Application.CutCopyMode = False
End With
End Sub

 

[asdasdasd123]

Benim için çok acil bir durum yardımcı olabilecek biri var mı ? Desteğiniz için şimdiden teşekkürler.

 

[Korhan Ayhan]

Profilinizdeki kullandığınız ofis sürümü bilgisini güncellemenizi rica ederim.

 

[asdasdasd123]

Merhaba Güncellenmiştir.

 

[Asri]

Bu kodları istediğiniz şekilde düzenleyerek sonuca ulaşabilirsiniz.

Sub menu()
    Sheets("Menu").Select
    mail = [G3]
    konu = [G4]
    mesaj = [G5]
    mesaj = Replace(mesaj, ",", ", <br>")
    Call mail_gonder
End Sub

Sub mail_gonder()
      Dim wrdEdit
      Dim alana, alanb, alanc, aland As Range
      
      sonsatir = Sheets("A").Cells(Rows.Count, "A").End(3).Row
      Set alana = Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("B").Cells(Rows.Count, "A").End(3).Row
      Set alanb = Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("C").Cells(Rows.Count, "A").End(3).Row
      Set alanc = Range("A14:G" & sonsatir)
      
      sonsatir = Sheets("D").Cells(Rows.Count, "A").End(3).Row
      Set aland = Range("A14:G" & sonsatir)
            
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = mail
       .CC = ""
       .Subject = konu
       .Display
      
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       .HTMLBody = mesaj & _
          "<br>" & "A'nın verileri;" & "<br>" & RangetoHTML(alana) & _
          "<br>" & "B'nın verileri;" & "<br>" & RangetoHTML(alana) & _
          "<br>" & "C'nın verileri;" & "<br>" & RangetoHTML(alana) & _
          "<br>" & "D'nın verileri;" & "<br>" & RangetoHTML(alana) & _
         .HTMLBody
       End With
      
      Set wrdEdit = Nothing
      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 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

 

[asdasdasd123]

Merhaba, Yapmaya Çalıştığım Mail Görselde ki gibidir. Sizin gönderdiğiniz kodları uyarlamaya çalıştığımda Mail Yazısı Baştan geliyor. Sonrasında Tablo ekleniyor. Tablo eklendiğinde Mail yazısını siliyor. Buna nasıl bir çözüm bulunabilir.

 

[asdasdasd123]

Merhaba Gerek Kalmadı ilginiz İçin Teşekkürler.