Excel eki olarak otomatil mail gönderme

Katılım
29 Kasım 2024
Mesajlar
9
Excel Vers. ve Dili
Excel 2016
merhabalar,

İnternette otomatik mail gönderme araştırmam sonucu aşağıdaki kodu gördüm, kullandım. Başarılı şekilde gönderiyorum ama benim gönderdiğim içerik çok fazla olduğu ve bir şeyi bulmak için filtre kullanılması gerektiği için excel eki olarak göndermem gerekiyor.

Bu mümkün mü?


Kod:
Sub MailGonder()

Dim EmailApp As Outlook.Application
Dim Source As String
Dim myRange As Range
Set myRange = Selection
Set EmailApp = New Outlook.Application

Dim EmailItem As Outlook.MailItem
Set EmailItem = EmailApp.CreateItem(olMailItem)

EmailItem.To = "gönderilecek mail adresi"
EmailItem.Subject = "Mail Başlığı"
EmailItem.HTMLBody = rangetoHTML(myRange)

EmailItem.Send
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

    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

    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.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function
 

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
683
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Kod:
Sub MailGonder()

    Dim EmailApp As Outlook.Application
    Dim Source As String
    Dim myRange As Range
    Dim EmailItem As Outlook.MailItem
    Dim ExcelDosyaYolu As String
  
    Set myRange = Selection    
    Set EmailApp = New Outlook.Application    
    Set EmailItem = EmailApp.CreateItem(olMailItem)
  
    EmailItem.To = "gönderilecek mail adresi"
    EmailItem.Subject = "Mail Başlığı"
    EmailItem.Body = "Merhabalar, bilmem ne dosyanın eki ektedir." 
    EmailItem.HTMLBody = rangetoHTML(myRange)
    
    ExcelDosyaYolu = Environ$("temp") & "\ExcelEki_" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
    ThisWorkbook.SaveAs ExcelDosyaYolu
  
    EmailItem.Attachments.Add ExcelDosyaYolu   
    EmailItem.Send  
   
    Application.Wait (Now + TimeValue("0:00:05")) ' 5 saniye bekle (mail gönderildikten sonra)
    Kill ExcelDosyaYolu

End Sub
Bu hata, Kill komutunun dosyayı silme işlemine izin verilmediği anlamına gelir. Sebebi, Outlook'un maili gönderirken dosyanın kilitlenmiş olması veya dosyanın hala açık olmasıdır. Bu durumu çözmek için Kill komutunu kullanmadan önce dosyanın tamamen kapandığından emin olun. Ayrıca, Outlook'un işlemi tamamladıktan sonra dosyanın silinmesi gerekeceği için, EmailItem.Send işleminden sonra silmeyi deneyebilirsiniz.

Bu şekilde, hem e-posta metni olarak seçili verilerle HTML formatında gönderilecektir hem de Excel dosyasını ek olarak gönderebilirsiniz.
 
Son düzenleme:
Katılım
29 Kasım 2024
Mesajlar
9
Excel Vers. ve Dili
Excel 2016
Kod:
Sub MailGonder()

    Dim EmailApp As Outlook.Application
    Dim Source As String
    Dim myRange As Range
    Dim EmailItem As Outlook.MailItem
    Dim ExcelDosyaYolu As String
  
    Set myRange = Selection   
    Set EmailApp = New Outlook.Application   
    Set EmailItem = EmailApp.CreateItem(olMailItem)
  
    EmailItem.To = "gönderilecek mail adresi"
    EmailItem.Subject = "Mail Başlığı"
    EmailItem.HTMLBody = rangetoHTML(myRange)
   
    ExcelDosyaYolu = Environ$("temp") & "\ExcelEki_" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
    ThisWorkbook.SaveAs ExcelDosyaYolu
 
    EmailItem.Attachments.Add ExcelDosyaYolu  
    EmailItem.Send

    Kill ExcelDosyaYolu

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

    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

    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.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function
Bu şekilde, hem e-posta metni olarak seçili verilerle HTML formatında gönderilecektir hem de Excel dosyasını ek olarak gönderebilirsiniz.
çok teşekkür ederim.
Bunu uyguladığımda maili gönderiyor ama run-time error'70': permission denied hatası veriyor.debug dediğimde Kill ExcelDosyaYolu sarı ile işaretli. mail gitmesinde bir sıkıntı yok ama bu sonra sorun çıkarır mı bilmiyorum.

birde mail giderken sadece excel eki olarak istiyorum. mail içeriğinde gönderdiğim excelin içeriği yerine yazacağım merhabalar, bilmem ne dosyanın eki ektedir. diye yazabilir miyim? ve gönderdiğim excelde görünmesini istemediğim sütunlar var. onları seçmeden göndermeme rağmen hepsini gönderiyor. sadece seçtiğim sütunların gitmesi mümkün mü?
 

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
683
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
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

With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=rng.Address, _ ' Burada 'UsedRange' yerine sadece seçilen aralığı belirliyoruz
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

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.Close savechanges:=False
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
2 nolu mesajı yeniden deneyin değişiklik yapıldı.
Kodda şu değişikliği yaparak yalnızca seçilen hücreyi gönderebilirsiniz:
 
Katılım
29 Kasım 2024
Mesajlar
9
Excel Vers. ve Dili
Excel 2016
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

With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=rng.Address, _ ' Burada 'UsedRange' yerine sadece seçilen aralığı belirliyoruz
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

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.Close savechanges:=False
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
2 nolu mesajı yeniden deneyin değişiklik yapıldı.
Kodda şu değişikliği yaparak yalnızca seçilen hücreyi gönderebilirsiniz:

2 nolu kod ile bu yazdığınızı birleştirdim. source:= rng.address kısmına seçeceğim alanı nasıl belirleyeceğim? o yüzden kodu çalıştıramadım sanırım.

mesela a, b c, d , e m, n, o, p , q, w, x sütununda yazanları göndermek istiyorum sadece.

birde yukarıda excel dosyasının silinmesi gerek demişsiniz. bu gönderdiğim excel listelerin üzerinde eklemeler, değişiklik vs yapıyorum. yani liste silinmemesi gerek. silinmeyecek değil mi? ben deneme yaptığım excel dosyası silinmedi çünkü.

birde bunu belirli saat ve günde otomatik kendisi yapsın yapabilir miyim?

With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=rng.Address, _ ' Burada 'UsedRange' yerine sadece seçilen aralığı belirliyoruz
HtmlType:=xlHtmlStatic)
.Publish (True

Sub MailGonder()

Dim EmailApp As Outlook.Application
Dim Source As String
Dim myRange As Range
Dim EmailItem As Outlook.MailItem
Dim ExcelDosyaYolu As String

Set myRange = Selection
Set EmailApp = New Outlook.Application
Set EmailItem = EmailApp.CreateItem(olMailItem)

EmailItem.To = "gönderilecek mail adresi"
EmailItem.Subject = "Mail Başlığı"
EmailItem.Body = "Merhabalar, bilmem ne dosyanın eki ektedir."
EmailItem.HTMLBody = rangetoHTML(myRange)

ExcelDosyaYolu = Environ$("temp") & "\ExcelEki_" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
ThisWorkbook.SaveAs ExcelDosyaYolu

EmailItem.Attachments.Add ExcelDosyaYolu
EmailItem.Send

Application.Wait (Now + TimeValue("0:00:05")) ' 5 saniye bekle (mail gönderildikten sonra)
Kill ExcelDosyaYolu

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

With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=rng.Address, _ ' Burada 'UsedRange' yerine sadece seçilen aralığı belirliyoruz
HtmlType:=xlHtmlStatic)
.Publish (True)
End With

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.Close savechanges:=False
Kill TempFile

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing

End Function
 
Son düzenleme:

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
683
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Kod:
Sub MailGonder()
    
    Dim EmailApp As Outlook.Application
    Dim Source As String
    Dim myRange As Range
    Dim EmailItem As Outlook.MailItem
    Dim ExcelDosyaYolu As String

    ' İstenilen hücre aralığını seçiyoruz (A1:A10, B1:B10 vb.)
    Set myRange = Union(Range("A1:A10"), Range("B1:B10"), Range("C1:C10"), Range("D1:D10"), Range("E1:E10"), _
                        Range("M1:M10"), Range("N1:N10"), Range("O1:O10"), Range("P1:P10"), Range("Q1:Q10"), _
                        Range("W1:W10"), Range("X1:X10"))
    
    Set EmailApp = New Outlook.Application
    Set EmailItem = EmailApp.CreateItem(olMailItem)
    
    EmailItem.To = "gönderilecek mail adresi"
    EmailItem.Subject = "Mail Başlığı"
    EmailItem.Body = "Merhabalar, bilmem ne dosyanın eki ektedir."
    EmailItem.HTMLBody = rangetoHTML(myRange)
    
    ExcelDosyaYolu = Environ$("temp") & "\ExcelEki_" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
    
    
    ThisWorkbook.SaveAs ExcelDosyaYolu
    EmailItem.Attachments.Add ExcelDosyaYolu
    EmailItem.Send
    Application.Wait (Now + TimeValue("0:00:05"))
    
    Kill ExcelDosyaYolu

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

  
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=rng.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
    
    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.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Sub ScheduleEmail()
    ' Her gün saat 08:00'de MailGonder
    Application.OnTime TimeValue("08:00:00"), "MailGonder"
End Sub
 
Katılım
29 Kasım 2024
Mesajlar
9
Excel Vers. ve Dili
Excel 2016
Kod:
Sub MailGonder()
   
    Dim EmailApp As Outlook.Application
    Dim Source As String
    Dim myRange As Range
    Dim EmailItem As Outlook.MailItem
    Dim ExcelDosyaYolu As String

    ' İstenilen hücre aralığını seçiyoruz (A1:A10, B1:B10 vb.)
    Set myRange = Union(Range("A1:A10"), Range("B1:B10"), Range("C1:C10"), Range("D1:D10"), Range("E1:E10"), _
                        Range("M1:M10"), Range("N1:N10"), Range("O1:O10"), Range("P1:P10"), Range("Q1:Q10"), _
                        Range("W1:W10"), Range("X1:X10"))
   
    Set EmailApp = New Outlook.Application
    Set EmailItem = EmailApp.CreateItem(olMailItem)
   
    EmailItem.To = "gönderilecek mail adresi"
    EmailItem.Subject = "Mail Başlığı"
    EmailItem.Body = "Merhabalar, bilmem ne dosyanın eki ektedir."
    EmailItem.HTMLBody = rangetoHTML(myRange)
   
    ExcelDosyaYolu = Environ$("temp") & "\ExcelEki_" & Format(Now, "dd-mm-yy h-mm-ss") & ".xlsx"
   
   
    ThisWorkbook.SaveAs ExcelDosyaYolu
    EmailItem.Attachments.Add ExcelDosyaYolu
    EmailItem.Send
    Application.Wait (Now + TimeValue("0:00:05"))
   
    Kill ExcelDosyaYolu

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

 
    With TempWB.PublishObjects.Add( _
        SourceType:=xlSourceRange, _
        Filename:=TempFile, _
        Sheet:=TempWB.Sheets(1).Name, _
        Source:=rng.Address, _
        HtmlType:=xlHtmlStatic)
        .Publish (True)
    End With
   
    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.Close savechanges:=False
    Kill TempFile

    Set ts = Nothing
    Set fso = Nothing
    Set TempWB = Nothing

End Function

Sub ScheduleEmail()
    ' Her gün saat 08:00'de MailGonder
    Application.OnTime TimeValue("08:00:00"), "MailGonder"
End Sub
Selamlar,

run-time error '1004' hatası veriyor ve maili göndermiyor. debug dediğimde aşağıdaki kodları sarı olarak gösteriyor.



With TempWB.PublishObjects.Add( _
SourceType:=xlSourceRange, _
Filename:=TempFile, _
Sheet:=TempWB.Sheets(1).Name, _
Source:=rng.Address, _
HtmlType:=xlHtmlStatic)
 

muhasebeciyiz

Altın Üye
Katılım
10 Şubat 2006
Mesajlar
683
Excel Vers. ve Dili
Office 2016
64 Bit
Altın Üyelik Bitiş Tarihi
21-12-2027
Alternatif HTML Çıktısı
Function rangetoHTML(rng As Range) As String
Dim fso As Object
Dim ts As Object
Dim TempFile As String
Dim TempWB As Workbook
Dim HTML As String
Dim Cell As Range
Dim Row As Range

TempFile = Environ$("temp") & "\" & Format(Now, "dd-mm-yy h-mm-ss") & ".htm"

rng.Copy
Set TempWB = Workbooks.Add
With TempWB.Sheets(1)
.Cells(1, 1).PasteSpecial Paste:=xlPasteValues
.Cells(1, 1).PasteSpecial Paste:=xlPasteFormats
End With

TempWB.SaveAs TempFile, xlHtml
TempWB.Close False

Set fso = CreateObject("Scripting.FileSystemObject")
Set ts = fso_OpenTextFile(TempFile, 1) ' 1 = Okuma Modu
HTML = ts.ReadAll
ts.Close

Kill TempFile

HTML = Replace(HTML, "align=center", "align=left")

rangetoHTML = HTML

Set ts = Nothing
Set fso = Nothing
Set TempWB = Nothing
End Function


Kodunuzdaki run-time error '1004' hatasının, PublishObjects.Add satırında meydana geldiğini belirttiniz. Bu hata genellikle Excel'in içindeki geçici dosya oluşturma veya HTML formatında çıktı alma sırasında oluşur. Bu hatanın nedeni genellikle geçici dosyanın oluşturulamaması veya Excel'in eski yöntemleri desteklememesidir.

Dosya Erişimi: Kodun geçici dosyaları kaydedip okuma işlemi yapabilmesi için Temp klasörüne yazma izninizin olması gerekir.

Excel Sürümü: Excel'in eski sürümleri, bazı özellikleri desteklemiyor olabilir. Bu tür durumlarda, SaveAs yöntemiyle dosyayı HTML formatında kaydetmek daha uygun olabilir.
 
Üst