• DİKKAT

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

  • Forum yazılımı güncelenmiştir.

    Beklenmedik durumlar görürseniz lütfen yönetime iletin.

Makro ile mail gönderme

  • Konbuyu başlatan Konbuyu başlatan Themars
  • Başlangıç tarihi Başlangıç tarihi
T

Themars

Katılım
3 Ocak 2023
Mesajlar
9
Excel Vers. ve Dili
Tr 2013
Merhaba,
Makro içeren bir raporumuz var, command button yardımı ile bu makro içeren Excel dosyasını makrosuz şekilde xls uzantılı olarak bir hücrede tanımlı kişiye mail gönderecek kodu nasıl yazabilirim ?
 
Merhaba,

Birçok şekilde arattım ancak tam çözümü bulamadım karşılaştığım ya pdf olarak gönderiyor ya da makro ile aktif çalışma sayfasını gönderiyor.
A1 ile AF40 hücreleri arasında bir rapor var ben hem exceli makrosuz göndersin istiyorum hemde mailin body kısmına bu hücre aralığını koysun istiyorum.
Kullandığım kod şu şekilde fakat işe yaramadı;

Kod: 
Sub mail()

Dim Sayfa As Worksheet
Dim Alan As Range
Dim daralan As Range

 
Set Alan = Worksheets("rapor").Range("A1:AF40")
Set Sayfa = Sheets("rapor")

gecicipath = ThisWorkbook.Path & "\"
pdffile = gecicipath & Range("w7") & " _ " & Range("I10") & " _ " & Range("w9") & " _ " & Range("I4") & ".pdf"
Alan.ExportAsFixedFormat Type:=xlTypePDF, Filename:=pdffile, openafterpublish:=False
    With Alan


        .Parent.Select
        Set daralan = ActiveCell
        .Select
        ActiveWorkbook.EnvelopeVisible = False
        With .Parent.MailEnvelope

            .Introduction = " Merhaba " & Sheets("calisma").Range("I1") & vbCrLf & vbCrLf & " Rapor ektedir."

            With .Item
                .To = Sheets("calisma").Range("I2")
                .CC = ""
                .Subject = "Rapor" & "_" & "Rapor No." & Range("I10")
                .BCC = ""
                .Attachments.Add pdffile
                .Send
            End With

        End With

        daralan.Select
    End With
    
    Sayfa.Select


    
    End Sub
 
Merhaba aşağıdaki kod kendinize göre ayarlayabilirsiniz.

Option Explicit
Sub Excel_ile_Mail_Gönderme()
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set rng = Sheets("rapor").UsedRange 'Gönderilecek sayfa ismi
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.HTMLBody = RangetoHTML(rng)
.Send 'göndermemek için .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)
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"
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
'Sayfayı htm dosyası olarak yayınla
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
'RangetoHTML içine htm dosyası olan tüm verileri oku
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=")
'TempWB'yi kapat
TempWB.Close savechanges:=False
'htm dosyası olan bu fonksiyonu sil
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
 
@ozuberk teşekkürler ancak bu seferde mail Attachments kısmına makrosuz .xlsx olarak eklemiyor.
 
@Themars rica ederim. Aşağıdaki kodları kendinize göre ayarlayabilirsiniz.

Option Explicit
Sub Excel_ile_Mail_Gönderme()
Call Kaydet
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set rng = Sheets("Rapor").UsedRange 'Gönderilecek sayfa ismi
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Attachments.Add ("C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx") 'Gönderilecek sayfa yolu
.HTMLBody = RangetoHTML(rng)
.Send 'göndermemek için .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)
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"
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
'Sayfayı htm dosyası olarak yayınla
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
'RangetoHTML içine htm dosyası olan tüm verileri oku
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=")
'TempWB'yi kapat
TempWB.Close savechanges:=False
'htm dosyası olan bu fonksiyonu sil
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub Kaydet()
Sheets("Rapor").Select
Sheets("Rapor").Copy
ChDir "C:\Users\kullanıcı\Desktop" 'Gönderilecek sayfa yolu
ActiveWorkbook.SaveAs Filename:="C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Gönderilecek sayfa yolu
ActiveWindow.Close
End Sub
 
@ozuberk merhaba, çok teşekkürler excel xlsx olarak ekleniyor maile. Ancak bu kod ile raporda bulunan görseller mailin body kısmında görünmüyor. Ayrıca mail gönder butonuna bastığımda kaydet kaydetme, daha önce bu isimle excel var vb. uyarılar veriyor. Bu sorunu nasıl çözebilirim. Destekleriniz için teşekkürler.
 
Merhaba bende body (A1:L10) kısmına yapıştırıyor. Alınan hata için değişiklik yaptım.

Option Explicit
Sub Excel_ile_Mail_Gönderme()
Call Kaydet
Dim rng As Range
Dim OutApp As Object
Dim OutMail As Object
With Application
.EnableEvents = False
.ScreenUpdating = False
End With
Set rng = Nothing
Set rng = ActiveSheet.UsedRange
Set rng = Sheets("Rapor").UsedRange 'Gönderilecek sayfa ismi
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
On Error Resume Next
With OutMail
.To = ""
.CC = ""
.BCC = ""
.Subject = ""
.Attachments.Add ("C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx") 'Gönderilecek sayfa yolu
.HTMLBody = RangetoHTML(rng)
.Send 'göndermemek için .Display
End With
On Error GoTo 0
With Application
.EnableEvents = True
.ScreenUpdating = True
End With
Set OutMail = Nothing
Set OutApp = Nothing
Kill "C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx"
End Sub
Function RangetoHTML(rng As Range)
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"
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
'Sayfayı htm dosyası olarak yayınla
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
'RangetoHTML içine htm dosyası olan tüm verileri oku
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=")
'TempWB'yi kapat
TempWB.Close savechanges:=False
'htm dosyası olan bu fonksiyonu sil
Kill TempFile
Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function
Sub Kaydet()
Sheets("Rapor").Select
Sheets("Rapor").Copy
ChDir "C:\Users\kullanıcı\Desktop" 'Gönderilecek sayfa yolu
ActiveWorkbook.SaveAs Filename:="C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Gönderilecek sayfa yolu
ActiveWindow.Close
End Sub
 
Merhaba, mailin body kısmına buton yardımıyla eklenen resimler hala görünmüyor.
Bir de şu hata ile karşılaştım; xlsx olarak eke koyduğumuz excel dosyasında da resimler görünmüyor.
 
Merhaba sorunun çözümünü hala bulabilmiş değilim, yardımlarınızı bekliyorum.
 
Merhaba umarım aşağıdaki kod işinizi görür.


Sub Excel_ile_Mail_Gönderme()
Call Kaydet

Dim OutApp As Object
Dim OutMail As Object
Dim table As Range
Dim pic As Picture
Dim ws As Worksheet
Dim wordDoc


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

'Tabloyu resme dönüştürme
Set ws = ThisWorkbook.Sheets("Rapor")
Set table = ws.Range("A1:AF40")
ws.Activate
table.Copy
Set pic = ws.Pictures.Paste
pic.Cut

'E-posta mesajı oluştur
On Error Resume Next
With OutMail
.To = "deneme@deneme.com"
.CC = ""
.BCC = ""
.Subject = "Deneme Data " & Format(Date, "mm-dd-yy")
.Attachments.Add ("C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx") 'Gönderilecek sayfa yolu
.Display

Set wordDoc = OutMail.GetInspector.WordEditor
With wordDoc.Range
.PasteandFormat wdChartPicture
.insertParagraphAfter
.insertParagraphAfter
.InsertAfter "Saygılarımla,"
.insertParagraphAfter
.InsertAfter "Excel"
End With

.HTMLBody = "Deneme1" & _
"Deneme2" & .HTMLBody
End With
On Error GoTo 0

Set OutApp = Nothing
Set OutMail = Nothing
Kill "C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx"
End Sub


Sub Kaydet()
Sheets("Rapor").Select
Sheets("Rapor").Copy
ChDir "C:\Users\kullanıcı\Desktop" 'Gönderilecek sayfa yolu
ActiveWorkbook.SaveAs Filename:="C:\Users\kullanıcı\Desktop\Rapor Ek.xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False 'Gönderilecek sayfa yolu
ActiveWindow.Close
End Sub
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst