• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Excel İçeriğini Buton ile Outlook Mail e Aktarma

F

fledermaus

Katılım
18 Kasım 2012
Mesajlar
423
Excel Vers. ve Dili
Microsoft Office 365
Merhabalar,


Ekte paylaşmış olduğum çalışma kitabında ilk sayfada bulunan yazılı A1:L48 (alanını/şablonunu yada print alanı) bir buton yardımı ile mail olarak otomatik nasıl açabilirim ?


1- Mail konusu: Y1 hücresinde yazılan veriler gelecek.

2- Çalışma sayfasında yazılan verileri aşağıdaki gibi kopyalayacak

3- Mail içeriğinde standart bir yazı olacak. (Makroya eklenebilir)

Örnek:





Yardımlarınız için şimdiden teşekkür eder, iyi çalışmalar dilerim.

Syg,
 

Ekli dosyalar

  • 1647953237080.png
    1647953237080.png
    23.4 KB · Görüntüleme: 12
  • Mail Açma.xlsx
    Mail Açma.xlsx
    15.6 KB · Görüntüleme: 4
Merhaba,

Konuyla ilgili yardımcı olabilecek birileri var mıdır ?

Syg,
 
Merhaba,

Umarım konuyu doğru açıklayabilmişimdir :)

Syg,
 
Merhaba,

Konuyla ilgili yardımcı olabilecek birileri var mıdır?

Syg,
 
Merhaba,

Forumda örnek uygulamalar var. Arama yapmanızı tavsiye ederim.

Bir örnek:

Excelden mail gönderme

Arkadaşlar merhaba, Excelde yazdırma alanı olarak seçili alanı buton üzerinden mail göndermek istiyorum, yardımlarınız için şimdiden teşekkürler.
www.excel.web.tr www.excel.web.tr

.
 
Ömer' Alıntı:
Merhaba,

Forumda örnek uygulamalar var. Arama yapmanızı tavsiye ederim.

Bir örnek:

Excelden mail gönderme

Arkadaşlar merhaba, Excelde yazdırma alanı olarak seçili alanı buton üzerinden mail göndermek istiyorum, yardımlarınız için şimdiden teşekkürler.
www.excel.web.tr www.excel.web.tr

.
Genişletmek için tıkla ...


Hocam Merhaba,

Yönlendirmeniz ve aramalarım neticesinde dosyam için az önce bir kod ekledim. Her şey dosdoğru çalışıyor.

Sadece mail içeriğine eklenen Range("A1:K50") alanın üzerine

1- Araya boşluk vererek "P13:U16" alanında oluşturacağım ve mail için hazırlamış olduğum bir başlık yazısı,

2- Mailin en altına ise outlook da kayıtlı imzam gelsin istiyorum.

Birde bu iki eklentiler için kodlama da nasıl bir revizyon yapmalıyım ? Ayrıca mail içerisinde Range("A1:K50") den çekilecek olan içeriğin üstüne gelecek "P13:U16" alanındaki yazı ile mailin en altına gelecek olan kayıtlı imzamın arasındaki boşlukları ayarlamak için kodlamada nereleri değiştirmeliyim ?

Yardımlarınız için şimdiden teşekkür ederim.

Syg,


Sub mail_gonder()
Dim wrdEdit
Dim alan As Range
sonsatir = Cells(Rows.Count, "A").End(3).Row
Set alan = Range("A1:K50")

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.Subject = Range("Y1")
.Display

'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
'.send
.HTMLBody = RangetoHTML(alan) & .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
 
Deneyiniz.
Mail ekranında gelen yazıları karşılaştırarak değiştireceğiniz yerleri kendinize göre uyarlarsınız.
Kod: 
Sub mail_gonder()
      Dim wrdEdit
      Dim alan1 As Range, alan2 As Range
      Set alan1 = Range("A1:K50")
      Set alan2 = Range("P3:U16")
          
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = "deneme@deneme" 'gidecek mail adresi
       .CC = "bilgi@mail.adresi"
       .BCC = "gizli.mail.adresi"
       .Subject = Range("Y1").Value 
       .Display
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       .HTMLBody = "Merhaba" & "<br><br>" & "Veriler Aşağıdadır." & "<br><br>" & RangetoHTML(alan1) & "<br><br>" & RangetoHTML(alan2) & .HTMLBody
       End With
    
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub

Function RangetoHTML(rng)
' 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
 
Ömer' Alıntı:
Deneyiniz.
Mail ekranında gelen yazıları karşılaştırarak değiştireceğiniz yerleri kendinize göre uyarlarsınız.
Kod: 
Sub mail_gonder()
      Dim wrdEdit
      Dim alan1 As Range, alan2 As Range
      Set alan1 = Range("A1:K50")
      Set alan2 = Range("P3:U16")
         
      Set OutApp = CreateObject("Outlook.Application")
      Set OutMail = OutApp.CreateItem(0)
      With OutMail
       .To = "deneme@deneme" 'gidecek mail adresi
       .CC = "bilgi@mail.adresi"
       .BCC = "gizli.mail.adresi"
       .Subject = Range("Y1").Value
       .Display
       'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
       '.send
       .HTMLBody = "Merhaba" & "<br><br>" & "Veriler Aşağıdadır." & "<br><br>" & RangetoHTML(alan1) & "<br><br>" & RangetoHTML(alan2) & .HTMLBody
       End With
   
      Set wrdEdit = Nothing
      Set OutMail = Nothing
      Set OutApp = Nothing
End Sub

Function RangetoHTML(rng)
' 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
Genişletmek için tıkla ...


Hocam Teşekkürler.

".HTMLBody = RangetoHTML(alan1) & "<br><br>" & RangetoHTML(alan2)" olarak revize edildi.

"Set alan2 = Range("A1:K50")
Set alan1 = Range("P3:U16") " kodları değiştirilerek dosyayı reviz ettim.


Ellerinize sağlık.

Syg,






Syg,
 
Hocam Tekrar Merhaba,

Bu konu ile ilgili ("P3:W16") alanını DATA isimli bir başka çalışma sayfası açarak ("B1:O1") hücre aralığına taşıdım.

Kodu ise "Set alan1 = Range("P3:W16")" ise aşağıdaki gibi değiştirdim ancak çalışmadı.

Set alan1 = Application.(ActiveWorkbook.Sheets("DATA").Range("B1:O1"))

Makroda yeni olduğum ve aynı çalışma kitabında başka bir çalışma sayfasında geçen hücre kodlamasına çok aşina olmadığımdan kodlama hatası yaptığımı düşünüyorum.

Nasıl bir düzeltme yapmam gerekli ? Yardımcı olabilirseniz sevinirim.

Syg,
 
Merhaba,

Yardımcı olabilecek birileri var mıdır ?

Syg,
 
Merhaba,

Konuyu kendim çözdüm teşekkürler.

Syg,
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst