Seçili Alanı Resim Olarak Kopyalayıp Mail Gönderme

[MiRaBiLiS]

Merhabalar üstadlar,

Aktif olarak kullandığım sayfamda seçili alanı kopyalayıp mail olarak gönderiyorum. Ancak tabloya resim eklemesi yapıldığında mailde görünmüyor ve tablodaki renkler farklı çıkıyor.

Benim istediğim şey seçili alanı outlooka tablo olarak değil resim olarak kopyalama yapması, maile ek olarak değil mailin içerisine koyması gerekiyor yani.

Aktif kullandığım kod:

Sub MailGonder0816()
    Range("T19:AA38").Select
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 = "mail adres"
EmailItem.To = "mail adres"
EmailItem.Subject = "08-16 Vardiya Sonu Raporu"
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

Bu konuda yardımcı olabilir misiniz acaba?

 

[MiRaBiLiS]

Kimseden ses çıkmayınca uzun uğraşılar sonucu ben hallettim. ihtiyacı olanlar için kod aşağıdadır. tek dikkat edilmesi gereken sayfa koruması devre dışı olmalıdır. eğer bunu kapatmanın bir yolu varsa hangi satır olduğunu gösterirseniz bende faydalanmış olurum.

Sub resimgonder()
    Range("A1:E30").Select
    
    Dim TempFilePath As String
    Dim xOutApp As Object
    Dim xOutMail As Object
    Dim xHTMLBody As String
    Dim xRg As Range
    Dim xSheet As Worksheet
    Dim xAcSheet As Worksheet
    Dim xFileName As String
    Dim xSrc As String
    On Error Resume Next
    TempFilePath = Environ$("temp") & "\RangePic\"
    If Len(VBA.Dir(TempFilePath, vbDirectory)) = False Then
      VBA.MkDir TempFilePath
    End If
    Set xAcSheet = Application.ActiveSheet
    For Each xSheet In Application.Worksheets
        xSheet.Activate
        Set xRg = xSheet.Application.Selection
        If xRg.Cells.Count > 1 Then
            Call createJpg(xSheet.Name, xRg.Address, "DashboardFile" & VBA.Trim(VBA.Str(xSheet.Index)))
        End If
    Next
    xAcSheet.Activate
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    Set xOutApp = CreateObject("outlook.application")
    Set xOutMail = xOutApp.CreateItem(olMailItem)
    xSrc = ""
    xFileName = Dir(TempFilePath & "*.*")
    Do While xFileName <> ""
        xSrc = xSrc + VBA.vbCrLf + "<img src='cid:" + xFileName + "'><br>"
        xFileName = Dir
        If xFileName = "" Then Exit Do
    Loop
    xHTMLBody = "<span LANG=tr>" _
                & "<p class=style2><span LANG=TR><font FACE=verdana SIZE=3>" _
                & "Sayın İlgililer;<br> " _
                & "MESAJ<br>" _
                & "<br> " _
                & xSrc _
                & "<br>Bilgilerinize.</font></span>"
    With xOutMail
        .Subject = ""
        .HTMLBody = xHTMLBody
        xFileName = Dir(TempFilePath & "*.*")
        Do While xFileName <> ""
            .Attachments.Add TempFilePath & xFileName, olByValue
            xFileName = Dir
        If xFileName = "" Then Exit Do
        Loop
        .To = ""
        .CC = ""
        .Subject = "KONU"
        '.Send
       .Display
    End With
    If VBA.Dir(TempFilePath & "*.*") <> "" Then
        VBA.Kill TempFilePath & "*.*"
    End If
End Sub
Sub createJpg(SheetName As String, xRgAddrss As String, nameFile As String)
    Dim xRgPic As Range
    ThisWorkbook.Activate
    Worksheets(SheetName).Activate
    Set xRgPic = ThisWorkbook.Worksheets(SheetName).Range(xRgAddrss)
    xRgPic.CopyPicture
    With ThisWorkbook.Worksheets(SheetName).ChartObjects.Add(xRgPic.Left, xRgPic.Top, xRgPic.Width, xRgPic.Height)
        .Activate
        .Chart.Paste
        .Chart.Export Environ$("temp") & "\RangePic\" & nameFile & ".jpg", "JPG"
    End With
    Worksheets(SheetName).ChartObjects(Worksheets(SheetName).ChartObjects.Count).Delete
Set xRgPic = Nothing
End Sub

 

[Korhan Ayhan]

Forumda outlook+resim ifadesi ile arama yaparsanız bolca örnek konuya erişebilirsiniz. Farklı örnekler paylaşıldı.

Korumayla ilgi arama sonuçlarını inceleyiniz.

Sorgu için arama sonuçları: koruma+makro+hata

www.excel.web.tr