Resim olarak outlook'a kopyalama

[Krall16]

Merhaba,

Elimde bir makro mevcut, zamanında bir yerden temin ederek kendim uyarlamıştım. Özetle yaptığı iş, excel'den outlook'a verileri tablo olarak kopyalamak ve mail metinlerini hazırlamak. Ancak bir süredir bu makroyu uyarladığım bazı excel dosyalarımda, resim olarak yapıştırmazsam devasa boyutlarda tablolar geliyor. Bu sebeple makromu "resim olarak yapıştır"a çevirmem lazım tablo olarak yapıştırmasının yerine (sütun sayısı sebebiyle, okunmak için resmi her seferinde bir miktar büyütmekteyim mail'de. Bunu otomatik yapamam sanırım?). İnternette ve buradaki forumumuzda bolca araştırma yaptım, ancak kimi makrolarla tek sekmeden resim alabildim, kiminde ise başka sorunlar yaşadım. Bu sebeple siz üstatlarıma danışma noktasına geldim. Makrom aşağıdadır;

Dim mail, konu, mesaj As String
Dim wrdEdit
Dim alana, alanb, alanc As Range

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

Sub mail_gonder()


sonsatir = Sheets("Veri 1").Cells(Rows.Count, "A").End(3).Row
Set alana = Sheets("Veri 1").Range("A10:T" & sonsatir)

sonsatir = Sheets("Veri 2").Cells(Rows.Count, "A").End(3).Row
Set alanb = Sheets("Veri 2").Range("A12:X" & sonsatir)

Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)
With OutMail
.To = "xx"
.CC = "xx"
.Subject = "Değişim"
.display

.HTMLBody = mesaj & _
"Merhaba," & "<br>" & _
"<br>" & "Aşağıdaki gibidir:" & "<br>" & _
"<br>" & "1. tablo;" & "<br>" & RangetoHTML(alana) & _
"<br>" & "2. tablo" & "<br>" & RangetoHTML(alanb) & _
"<br>" & "Bilginize sunar, iyi çalışmalar dilerim." & "<br>" & _
.HTMLBody

'Maili otomatik göndermek için .send deki tırnak işaretini kaldırın.
'.send
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-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

 

[Krall16]

Mesajımın içerisinde parantez içerisinde belirttiğim alan arada kaynamasın diye ayrıca belirtiyorum;

Resmi manuel olarak kendim mail'e eklediğimde, sütun sayısı sebebiyle, okunmak için resmi her seferinde bir miktar büyütmekteyim, yoksa küçük görünmekte. Makro ile otomatikleştirildiğinde, bu boyut ayarlamasını otomatik yapamam sanırım, değil mi?

 

[Krall16]

Günaydın,

Bilen bir arkadaşımız destek olursa çok sevinirim. Şimdiden teşekkür ederim.

 

[Krall16]

Merhaba,

Destek olabilecek biri çıkarsa çok sevinirim.