HTMLBODY(ALAN) İÇERİSİNE EXCEL EKRAN GÖRÜNTÜSÜ EKLEME

bdrymrl · 18 Ağustos 2024

Merhaba
Belirli bir alanı seçerek diğer konu kişi mail iç yazısı alanları yazıp mail gönderen bir makrom var. Bu seçili alanı mail içine yapıştırmasını değil bu seçili alanın ekran görüntüsünü almasını istiyorum ama bir türlü çeviremedim.

Sub mail_gonder()
Dim alan As Range

mailkonu = Range("AD1").Value
Mail = Range("AD2").Value
mailcc = Range("AD3").Value
mailmesaj = Range("AD4").Value

sonsatir = Cells(Rows.Count, "I").End(1).Row
If sonsatir < 20 Then sonsatir = 50

Set alan = Range("A1:J" & sonsatir)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = Mail
.CC = mailcc
.Subject = mailkonu
.Display

.HTMLBody = mailmesaj & RangetoHTML(alan) & .HTMLBody
.Attachments.Add "C:\Users\.......................\Desktop\STAMPING.xlsm"
End With

Set wrdEdit = Nothing
Set OutMail = Nothing
Set OutApp = Nothing
End Sub

tukayf · 18 Ağustos 2024

Kod:

Sub mail_gonder()
    Dim alan As Range
    Dim ws As Worksheet
    Dim pic As Picture
    Dim picPath As String
    Dim shp As Shape

   
    mailkonu = Range("AD1").Value
    Mail = Range("AD2").Value
    mailcc = Range("AD3").Value
    mailmesaj = Range("AD4").Value

    sonsatir = Cells(Rows.Count, "I").End(1).Row
    If sonsatir < 20 Then sonsatir = 50

    Set ws = ThisWorkbook.Sheets("Sayfa1") 
    Set alan = ws.Range("A1:J" & sonsatir)

   
    alan.Copy
    Set shp = ws.Pictures.Paste

    picPath = ThisWorkbook.Path & "\temp_image.png"
    shp.Copy
    Set pic = shp
    With ws.ChartObjects.Add(Left:=0, Width:=pic.Width, Top:=0, Height:=pic.Height)
        .Chart.Paste
        .Chart.Export Filename:=picPath, FilterName:="PNG"
        .Delete
    End With
    shp.Delete

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

    With OutMail
        .To = Mail
        .CC = mailcc
        .Subject = mailkonu
        .Display

   
        .HTMLBody = mailmesaj & "<br><br><img src='" & picPath & "'><br><br>" & .HTMLBody
        .Attachments.Add "C:\Users\.......................\Desktop\STAMPING.xlsm"
    End With


    Kill picPath

    Set pic = Nothing
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

deneyebilir misiniz. nette bulduğum kadarıyla ama hocalarımız revize edebilirler.

bdrymrl · 18 Ağustos 2024

teşekkürler ama hata veriyor,bu adımda. picPath = ThisWorkbook.Path & "\temp_image.png"
şunu farkettim makro içinde adımlıyordum dosya içine döndüğümde tuhaf bir ekran görüntüsü almış ): excelin kendi içerisine tüm satırların arka planını silip gölgeli bir ekran görüntüsü atmış.
bu ekran görüntüsünü mail içerisine yazacak.
Orjinal makronun tamamı altta

Sub mail_gonder()
Dim alan As Range

mailkonu = Range("AD1").Value
Mail = Range("AD2").Value
mailcc = Range("AD3").Value
mailmesaj = Range("AD4").Value

sonsatir = Cells(Rows.Count, "I").End(1).Row
If sonsatir < 20 Then sonsatir = 50

Set alan = Range("A1:J" & sonsatir)
Set OutApp = CreateObject("Outlook.Application")
Set OutMail = OutApp.CreateItem(0)

With OutMail
.To = Mail
.CC = mailcc
.Subject = mailkonu
.Display

.HTMLBody = mailmesaj & RangetoHTML(alan) & .HTMLBody
.Attachments.Add "C:\Users\bedriye.arica\Desktop\KALİTE STAMPING.xlsm"
End With

Set wrdEdit = Nothing
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

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

ublishsource=", _
"align=left x

ublishsource=")

TempWB.Close savechanges:=False

Kill TempFile

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

necati · 18 Ağustos 2024

bdrymrl' Alıntı:
teşekkürler ama hata veriyor,bu adımda. picPath = ThisWorkbook.Path & "\temp_image.png"

Merhaba, Dim shp As Shape satırını Dim shp As Picture şeklinde değiştirip deneyiniz.

tukayf · 18 Ağustos 2024

Kod:

Sub mail_gonder()
    Dim alan As Range
    Dim ws As Worksheet
    Dim picPath As String
    Dim shp As Shape

    mailkonu = Range("AD1").Value
    Mail = Range("AD2").Value
    mailcc = Range("AD3").Value
    mailmesaj = Range("AD4").Value

    sonsatir = Cells(Rows.Count, "I").End(1).Row
    If sonsatir < 20 Then sonsatir = 50

    Set alan = Range("A1:J" & sonsatir)
    Set ws = ThisWorkbook.Sheets("Sayfa1")

    alan.Copy
    Set shp = ws.Pictures.Paste

    picPath = Environ$("temp") & "\temp_image.png"
    shp.Copy
    With ws.ChartObjects.Add(Left:=0, Width:=shp.Width, Top:=0, Height:=shp.Height)
        .Chart.Paste
        .Chart.Export Filename:=picPath, FilterName:="PNG"
        .Delete
    End With
    shp.Delete

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

    With OutMail
        .To = Mail
        .CC = mailcc
        .Subject = mailkonu
        .Display

        .HTMLBody = mailmesaj & "<br><br><img src='" & picPath & "'><br><br>" & .HTMLBody
        .Attachments.Add "C:\Users\bedriye.arica\Desktop\KALİTE STAMPING.xlsm"
    End With

    Kill picPath

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

benim boyumu aşıyor ama böyle dener misiniz.

bdrymrl · 18 Ağustos 2024

tukayf' Alıntı:

Kod:

Sub mail_gonder()
    Dim alan As Range
    Dim ws As Worksheet
    Dim picPath As String
    Dim shp As Shape

    mailkonu = Range("AD1").Value
    Mail = Range("AD2").Value
    mailcc = Range("AD3").Value
    mailmesaj = Range("AD4").Value

    sonsatir = Cells(Rows.Count, "I").End(1).Row
    If sonsatir < 20 Then sonsatir = 50

    Set alan = Range("A1:J" & sonsatir)
    Set ws = ThisWorkbook.Sheets("Sayfa1")

    alan.Copy
    Set shp = ws.Pictures.Paste

    picPath = Environ$("temp") & "\temp_image.png"
    shp.Copy
    With ws.ChartObjects.Add(Left:=0, Width:=shp.Width, Top:=0, Height:=shp.Height)
        .Chart.Paste
        .Chart.Export Filename:=picPath, FilterName:="PNG"
        .Delete
    End With
    shp.Delete

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

    With OutMail
        .To = Mail
        .CC = mailcc
        .Subject = mailkonu
        .Display

        .HTMLBody = mailmesaj & "<br><br><img src='" & picPath & "'><br><br>" & .HTMLBody
        .Attachments.Add "C:\Users\bedriye.arica\Desktop\KALİTE STAMPING.xlsm"
    End With

    Kill picPath

    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

benim boyumu aşıyor ama böyle dener misiniz.

teşekkürler hocam ama olmadı

bdrymrl · 18 Ağustos 2024

necati' Alıntı:
Merhaba, Dim shp As Shape satırını Dim shp As Picture şeklinde değiştirip deneyiniz.

teşekkürler bu oldu ama debug modunda adımlayarak gittiğimde resmi alıyor ekran görüntüsünü maile ama direk çalıştır dediğimde maile boş görüntü alıyor.Debug da aldığı ekran görüntüsü mail içinde tam istediğim gibi tam sayfa ama gönder dediğimde gelen mailde resim çok aşırı küçülmüş şekilde geliyor.

necati · 19 Ağustos 2024

bdrymrl' Alıntı:
teşekkürler bu oldu ama debug modunda adımlayarak gittiğimde resmi alıyor ekran görüntüsünü maile ama direk çalıştır dediğimde maile boş görüntü alıyor.Debug da aldığı ekran görüntüsü mail içinde tam istediğim gibi tam sayfa ama gönder dediğimde gelen mailde resim çok aşırı küçülmüş şekilde geliyor.

Görüntünün aşırı küçük olması fotoğrafı çekilen alanın aşırı büyük olduğuna işaret ediyor.
Görüntü sınırlarını belirleyen değer "sonsatır" değişkenidir.
F8 ile adım adım giderek sonsatir = Cells(Rows.Count, "I").End(1).Row değişkeninin aldığı değeri okuyun.
Eğer 1 milyon küsür bir değer ise formülünüzü gerçek son satır değerini alacak şekilde değiştirin.

Biolightant · 19 Ağustos 2024

bdrymrl' Alıntı:
sonsatir = Cells(Rows.Count, "I").End(1).Row
If sonsatir < 20 Then sonsatir = 50

Set alan = Range("A1:J" & sonsatir)

sonsatir I sütunun mu yoksa J sütunun mu
veya yazdığınız doğru I sütunun u referans alıp J satırınımı belirliyorsunuz

bdrymrl · 19 Ağustos 2024

necati' Alıntı:
Görüntünün aşırı küçük olması fotoğrafı çekilen alanın aşırı büyük olduğuna işaret ediyor.
Görüntü sınırlarını belirleyen değer "sonsatır" değişkenidir.
F8 ile adım adım giderek sonsatir = Cells(Rows.Count, "I").End(1).Row değişkeninin aldığı değeri okuyun.
Eğer 1 milyon küsür bir değer ise formülünüzü gerçek son satır değerini alacak şekilde değiştirin.

Son satır tanımını değiştirdim aralık verdim bu şekilde debug ile ilerlediğimde istediğim görüntüyü alıyorum boyut olarak da ama run modunda otomatik ilerlerken ekran görüntüsünü boş alıyor .

bdrymrl · 19 Ağustos 2024

Biolightant' Alıntı:
sonsatir I sütunun mu yoksa J sütunun mu
veya yazdığınız doğru I sütunun u referans alıp J satırınımı belirliyorsunuz

İkisi de I olacak onu değiştirdim.

necati · 19 Ağustos 2024

Örnek dosya yükleyebilirmisiniz?

Biolightant · 19 Ağustos 2024

Merhaba,

C++:

Option Explicit
Sub HucreFotoToOutlook()
    Dim mailkonu As String
    Dim Mail As String
    Dim mailcc As String
    Dim mailmesaj As String
    Dim sonsatir As Long
    Dim mailHTML As String
    Dim ResimAlan As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EkDosya01 As String
    Dim EkDosya02 As String

    ' E-posta bilgilerinin alınması
    mailkonu = Range("AD1").Value ' E-posta konusu
    Mail = Range("AD2").Value ' Alıcı e-posta adresi
    mailcc = Range("AD3").Value ' Bilgilendirilecek Ek Alıcılar e-posta adresleri (Gözükür)
    mailmesaj = Range("AD4").Value ' Düz Metin mesajı

    ' Son satırın bulunması ve resim alınacak hücre alanının belirlenmesi
    sonsatir = Cells(Rows.Count, "I").End(xlUp).Row ' I sütununda en son dolu hücre
    If sonsatir < 20 Then sonsatir = 50 ' sonsatır minimum 50 olsun
    Set ResimAlan = Range("A1:I" & sonsatir) ' Bu alanın resmini çek

    ' Hücrelerin resmini çek ve geçici ( Environ$("temp") & "\ExcelHucreResim.jpg" )dosya olarak kaydet
    Hucrelere_Resim_Cek ResimAlan
    DoEvents

    ' Dosya yollarını değişkenlere atama
    EkDosya01 = Environ$("temp") & "\ExcelHucreResim.jpg" ' Hücrelerin resim dosyası
    EkDosya02 = Environ$("USERPROFILE") & "\Desktop\KALİTE STAMPING.xlsm" ' Excel dosyası

    mailHTML = "<p><img src='" & EkDosya01 & "'></p>" ' HTML resim olarak mesaj

    ' Outlook Uygulaması oluştur
    Set OutApp = CreateObject("Outlook.Application")

    ' Yeni bir e-posta öğesi oluştur
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Mail ' Alıcı e-posta adresi
        .CC = mailcc ' Alıcı ek e-posta adresleri (gözükür)
        .Subject = mailkonu ' E-posta konusu
        .HTMLBody = mailmesaj & mailHTML ' HTML formatında gövde metni
        .Attachments.Add EkDosya01 ' Hücre resmini ek olarak ekle
        .Attachments.Add EkDosya02 ' Excel dosyasını ek olarak ekle
        .Display ' E-postayı görüntüle (veya .Send ile gönder)
    End With

    ' Obje değişkenlerini serbest bırak
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Private Function Hucrelere_Resim_Cek(ResimHucre As Range)
    Dim Grafik As Object

    ' Hücre aralığının resim olarak kopyalanması
    ResimHucre.CopyPicture xlScreen, xlBitmap
    ActiveSheet.Paste
    Selection.Cut

    ' Geçici grafik nesnesi oluştur ve resimi içine yapıştır
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=ResimHucre.Width, Height:=ResimHucre.Height)

    Grafik.Activate
    Grafik.Chart.Paste
    Grafik.Chart.Export Environ$("temp") & "\ExcelHucreResim.jpg" ' Resmi JPG olarak kaydet
    Grafik.Delete ' Geçici grafik nesnesini sil

End Function

bdrymrl · 19 Ağustos 2024

Biolightant' Alıntı:

Merhaba,

C++:

Option Explicit
Sub HucreFotoToOutlook()
    Dim mailkonu As String
    Dim Mail As String
    Dim mailcc As String
    Dim mailmesaj As String
    Dim sonsatir As Long
    Dim mailHTML As String
    Dim ResimAlan As Range
    Dim OutApp As Object
    Dim OutMail As Object
    Dim EkDosya01 As String
    Dim EkDosya02 As String

    ' E-posta bilgilerinin alınması
    mailkonu = Range("AD1").Value ' E-posta konusu
    Mail = Range("AD2").Value ' Alıcı e-posta adresi
    mailcc = Range("AD3").Value ' Bilgilendirilecek Ek Alıcılar e-posta adresleri (Gözükür)
    mailmesaj = Range("AD4").Value ' Düz Metin mesajı

    ' Son satırın bulunması ve resim alınacak hücre alanının belirlenmesi
    sonsatir = Cells(Rows.Count, "I").End(xlUp).Row ' I sütununda en son dolu hücre
    If sonsatir < 20 Then sonsatir = 50 ' sonsatır minimum 50 olsun
    Set ResimAlan = Range("A1:I" & sonsatir) ' Bu alanın resmini çek

    ' Hücrelerin resmini çek ve geçici ( Environ$("temp") & "\ExcelHucreResim.jpg" )dosya olarak kaydet
    Hucrelere_Resim_Cek ResimAlan
    DoEvents

    ' Dosya yollarını değişkenlere atama
    EkDosya01 = Environ$("temp") & "\ExcelHucreResim.jpg" ' Hücrelerin resim dosyası
    EkDosya02 = Environ$("USERPROFILE") & "\Desktop\KALİTE STAMPING.xlsm" ' Excel dosyası

    mailHTML = "<p><img src='" & EkDosya01 & "'></p>" ' HTML resim olarak mesaj

    ' Outlook Uygulaması oluştur
    Set OutApp = CreateObject("Outlook.Application")

    ' Yeni bir e-posta öğesi oluştur
    Set OutMail = OutApp.CreateItem(0)

    With OutMail
        .To = Mail ' Alıcı e-posta adresi
        .CC = mailcc ' Alıcı ek e-posta adresleri (gözükür)
        .Subject = mailkonu ' E-posta konusu
        .HTMLBody = mailmesaj & mailHTML ' HTML formatında gövde metni
        .Attachments.Add EkDosya01 ' Hücre resmini ek olarak ekle
        .Attachments.Add EkDosya02 ' Excel dosyasını ek olarak ekle
        .Display ' E-postayı görüntüle (veya .Send ile gönder)
    End With

    ' Obje değişkenlerini serbest bırak
    Set OutMail = Nothing
    Set OutApp = Nothing
End Sub

Private Function Hucrelere_Resim_Cek(ResimHucre As Range)
    Dim Grafik As Object

    ' Hücre aralığının resim olarak kopyalanması
    ResimHucre.CopyPicture xlScreen, xlBitmap
    ActiveSheet.Paste
    Selection.Cut

    ' Geçici grafik nesnesi oluştur ve resimi içine yapıştır
    Set Grafik = ActiveSheet.ChartObjects.Add(Left:=0, Top:=0, Width:=ResimHucre.Width, Height:=ResimHucre.Height)

    Grafik.Activate
    Grafik.Chart.Paste
    Grafik.Chart.Export Environ$("temp") & "\ExcelHucreResim.jpg" ' Resmi JPG olarak kaydet
    Grafik.Delete ' Geçici grafik nesnesini sil

End Function

Çok teşekkürler bu oldu sadece ekran görüntüsünü aynı zamanda ek dosya olarak eklemiş onu kaldırdım tam istediğim gibi oldu.

Biolightant · 19 Ağustos 2024

bdrymrl' Alıntı:
ek dosya olarak eklemiş onu kaldırdım

Kodlar sizde istediğiniz gibi değiştirebilirsiniz.
( bazı kullanıcılar HTML mail sevmez, kabul etmeyebilir diye extra dan eklemiştim)
Kolay gelsin.