RangeToHTML &单元格中的图像 [英] RangeToHTML & Image in Cell

问题描述

我正在尝试使用 Ron de Bruin 的 RangeToHTML 生成一封电子邮件，到目前为止它运行良好，但是我的一个单元格(B26")包含一个图像，这不会复制到电子邮件中.

Im trying to generate an email using Ron de Bruin's RangeToHTML and its working perfectly so far however one of my cells ("B26") contains an image and this wont copy into the email.

我已尝试并成功地在范围之前或之后添加图像，但我需要此图像出现在此特定单元格中.如果可能的话，我有什么想法可以让它发挥作用吗?

I've tried and succeded in adding in the image before or after the range but I need this image to appear in this specific cell. Any Ideas how I can get this to work if its at all possible?

Sub SendEmail()

    Dim OutlookApp As Outlook.Application
    Dim MItem As Outlook.MailItem
    Dim cell As Range
    Dim Subj As String
    Dim EmailAddr As String
    Dim Recipient As String
    Dim rng As Range
    Dim rng2 As Range
    Dim StrBody As String

    Set rng = Sheets("Email Templates").Range("A1:D29")
    'Set rng2 = Sheets("Email Templates").Range("A6:D32").SpecialCells(xlCellTypeVisible)

    'Create Outlook object
    Set OutlookApp = New Outlook.Application

    'Operations Contacts
    For Each cell In Sheets("Contacts").Columns("A").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next

    'Systems Contacts
    For Each cell In Sheets("Contacts").Columns("B").Cells.SpecialCells(xlCellTypeVisible)
        If cell.Value Like "*@*" Then
            EmailAddr = EmailAddr & ";" & cell.Value
        End If
    Next

    Subj = "Systems Notification | System Outage | " & Sheets("Email Templates").Range("C6") & " " & Sheets("Email Templates").Range("C4") & " " & Sheets("Email Templates").Range("C6")

    'Create Mail Item and view before sending
    Set MItem = OutlookApp.CreateItem(olMailItem)
    With MItem
        .To = EmailAddr
        .Subject = Subj
        .HTMLBody = RangetoHTML(rng)
        .Display
    End With

End Sub



Function RangetoHTML(rng As Range)
' By Ron de Bruin.
    Dim fso As Object
    Dim ts As Object
    Dim TempFile As String
    Dim TempWB As Workbook
    Dim r As Long

    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).PasteSpecial xlPasteAllUsingSourceTheme, , False, False
        .Cells(1).Select
        Application.CutCopyMode = False
        On Error Resume Next
        .DrawingObjects.Visible = True
        .DrawingObjects.Delete
        On Error GoTo 0
        For r = 1 To rng.Rows.Count
            .Rows(r).RowHeight = rng.Rows(r).RowHeight
        Next r
    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 x:publishsource=", _
                          "align=left x:publishsource=")
    RangetoHTML = Replace(RangetoHTML, "<!--[if !excel]>&nbsp;&nbsp;<![endif]-->", "")

    '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

推荐答案

Y你可以通过截取相关范围的屏幕截图(使用 VBA 代码)来实现它(必须在屏幕中可见)，然后在 Outlook 中保存和导入该图像..

You can achieve it by taking a screenshot(using VBA Code) of the relevant range (Has to be visible in the screen) and then save and import that image in Outlook..

这会让你开始.我已经添加了评论，所以你理解它应该没有问题.如果您仍然这样做，请直接询问.

This will get you started. I have added the comments so you should not have a problem understanding it. If you still do then simply ask.

Option Explicit

Sub SaveRngAsImage()
    Dim flName As String
    Dim ws As Worksheet
    Dim shp As Shape
    Dim objChart As ChartObject
    Dim chrt As Chart

    Set ws = ActiveSheet

    '~~> Change as applicable
    flName = "C:Users
outsDesktopMyRng.jpg"

    '~~> Delete the above image
    If Dir(flName) <> "" Then Kill flName

    '~~> Check if what the user selected is a valid range
    If TypeName(Selection) <> "Range" Then
        MsgBox "Select a range first."
        Exit Sub
    End If

    '~~> Take a screenshot of the range
    Selection.CopyPicture xlScreen, xlBitmap
    DoEvents

    '~~> Paste the screenshot in the worksheet and assign it to
    '~~> a shape object so that we can use it's approx width and
    '~~> Height to create the chart object
    With ws
        .Paste
        DoEvents
        Set shp = .Shapes(.Shapes.Count)
        Set objChart = ActiveSheet.ChartObjects.Add(0, 0, shp.Width, shp.Height)
        Set chrt = objChart.Chart

        With chrt
            shp.Copy '~~> Copy the shape (in case the clipboard is cleared)
            .ChartArea.Select
            .Paste
            '~~> Save the image
            .Export ("C:Users
outsDesktopMyRng.jpg")
        End With
        shp.Delete
        objChart.Delete
    End With

    '~~> Attaching the above image to outlook email body
    'https://stackoverflow.com/questions/44869790/embed-picture-in-outlook-mail-body-excel-vba
    Dim OutApp As Object
    Dim OutMail As Object

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

    With OutMail
        .To = "[e-mail]"
        .Subject = "Attaching an image"
        .Attachments.Add flName, 1, 0
        .HtmlBody = "<html><p>Dear XYZ</p>" & _
        "<img src=""cid:MyRng.jpg"">"
        .Display
    End With
End Sub

截图

这篇关于RangeToHTML &单元格中的图像的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！