Question

我试图修改Ron de Bruins宏来发送邮件正文中的图表。首先，我导出图表并将其保存为PNG图像，然后我修改HTML代码将其添加到消息中。宏应该在服务器上运行，并将邮件发送给在我的工作场所工作的其他人。当我使用MailItem.Display方法并手动点击＆＃34;发送＆＃34;当我的消息出现时，一切正常。当我尝试使用MailItem.Send方法时，它没有 - 在邮件正文中我得到一个图标，就像它试图附加一个它无法找到的图像。有趣的是，当我从服务器发送该邮件时，在服务器帐户上，图表显示为corectly。只有当我尝试将其发送到本地＆＃34;它才能工作。计算机。

Sub wyslij()

NameOfThisFile = ActiveWorkbook.Name

Dim rng As Range
Dim dataminus1, dataminus2 As Date
Dim olApp As Outlook.Application
Set olApp = CreateObject("Outlook.Application")

Dim olMail As Outlook.MailItem
Set olMail = olApp.CreateItem(olMailItem)

Set rng = Nothing
Set rng = Sheets(2).Range("E1:P13")


olMail.To = "xxx@xxx" 
olMail.CC = "xxxx@xxx"

olMail.Subject = "xxxx"

olMail.HTMLBody = RangetoHTML(rng)

olMail.Display
'olMail.Send

'Delete file after sending a mail
'Call DeleteFile(Path)

End Sub

Sub Save_ChartAsImage()

ChartEx = False

Dim cht As ChartObject

For Each cht In ActiveSheet.ChartObjects
If cht.TopLeftCell.Column = ChartCol And cht.TopLeftCell.Row = ChartRow Then
    ChartEx = True
    On erRROR GoTo Err_Chart
    cht.Chart.Export Filename:=ActiveWorkbook.Path & "\Chart.png", Filtername:="PNG"
End If
Next cht

Err_Chart:
If Err <> 0 Then

Debug.Print Err.Description

Err.Clear

End If
End Sub

Function RangetoHTML(rng As Range)
' Changed by Ron de Bruin 28-Oct-2006
' Working in Office 2000-2013

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 xlPasteAll
    .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


'kopiujemy wykres z poprzedniego działu
'Workbooks("WplatyFinal.xlsm").Activate
Workbooks(NameOfThisFile).Activate
Call Save_ChartAsImage

TempWB.Activate

TempWB.Sheets(1).Select


'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

If ChartEx Then
 RangetoHTML = RangetoHTML & "<img src ='" & ActiveWorkbook.Path & "\Chart.png" & "'>"
End If

RangetoHTML = Replace(RangetoHTML, "align=center x:publishsource=", _
                      "align=left x:publishsource=")

'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

我还想提一下，我尝试在Send方法之后直接使用Wait函数，但遗憾的是它没有帮助。

Answer 1

使图像显示为内联当然是可能的。 HTML中的img src必须引用带有图像标识符的cid。下面的代码设置了电子邮件，并将所有图表对象作为内嵌图像添加到电子邮件中。

选项明确

Sub CreateEmail()
    Const PR_ATTACH_MIME_TAG = "http://schemas.microsoft.com/mapi/proptag/0x370E001E"
    Const PR_ATTACH_CONTENT_ID = "http://schemas.microsoft.com/mapi/proptag/0x3712001E"
    Dim wb As Workbook
    Dim ws As Worksheet
    Dim olApp As Object
    Dim olMail As Object
    Dim msg As String
    Dim msgGreeting As String
    Dim msgPara1 As String
    Dim msgEnding As String
    Dim chrt As ChartObject
    Dim fname As String
    Dim ident As String
    Dim tempFiles As Collection
    Dim imgIdents As Collection
    Dim imgFile As Variant
    Dim attchmt As Object
    Dim oPa As Object
    Dim i As Integer

    '--- create the email body with HTML-formatted content
    msgGreeting = "<bold>Dear Sirs</bold>,<br><br>"
    msgPara1 = "<div>Here is the data you requested:</div>"
    msgEnding = "<br><br>Sincerely,<br>JimBob<br>"

    '--- build the other email body content
    Set wb = ActiveWorkbook
    Set ws = ActiveSheet
    msg = msgGreeting & msgPara1
    '--- loops and adds all charts found on the worksheet
    If ws.ChartObjects.Count > 0 Then
        Set tempFiles = New Collection
        Set imgIdents = New Collection
        For Each chrt In ws.ChartObjects
            fname = ""
            msg = msg & ChartToEmbeddedHTML(chrt, fname, ident) & "<br><br>"
            tempFiles.Add fname
            imgIdents.Add ident
        Next chrt
    End If
    msg = msg & msgEnding

    '--- create the mail item
    Set olApp = CreateObject("Outlook.Application")
    Set olMail = olApp.CreateItem(0)                'olMailItem=0
    With olMail
        .To = "yyy@zzzz.com"
        '.CC = "xxxx@xxx"
        .Subject = "xxxx"
        .bodyformat = 2        'olFormatHTML=2
        '--- each of the images is referenced as a filename, but each one must be
        '    individually added as an attachment, then the attachment properties
        '    set to show the attachment as "inline". Because the image will be
        '    inlined, we'll use the "ident" as the reference (internal to the
        '    message body HTML)
        If (Not tempFiles Is Nothing) Then
            For i = 1 To tempFiles.Count
                Set attchmt = .attachments.Add(tempFiles.Item(i))
                Set oPa = attchmt.PropertyAccessor
                oPa.SetProperty PR_ATTACH_MIME_TAG, "image/png"
                oPa.SetProperty PR_ATTACH_CONTENT_ID, imgIdents.Item(i)
            Next i
        End If
        '--- the email item needs to be saved first
        .Save
        '--- now add the message contents
        .htmlbody = msg
        .display
    End With
    '--- delete the temp files now
    For Each imgFile In tempFiles
        Kill imgFile
    Next imgFile
    '--- clean up and get out
    Set tempFiles = Nothing
    Set imgIdents = Nothing
    Set attchmt = Nothing
    Set oPa = Nothing
    Set olMail = Nothing
    Set olApp = Nothing
    Set ws = Nothing
    Set wb = Nothing
End Sub

Private Function ChartToEmbeddedHTML(thisChart As ChartObject, _
                             ByRef tmpFile As String, _
                             ByRef ident As String) As String
    Dim html As String
    ident = RandomString(8)
    tmpFile = thisChart.Parent.Parent.Path & "\" & ident & ".png"

    thisChart.Activate
    thisChart.Chart.Export Filename:=tmpFile, Filtername:="png"
    html = "<img alt='Excel Chart' src='cid:" & ident & "'></img>"
    ChartToEmbeddedHTML = html
End Function

Private Function RandomString(strlen As Integer) As String
    Dim i As Integer, iTemp As Integer, bOK As Boolean, strTemp As String
    '48-57 = 0 To 9, 65-90 = A To Z, 97-122 = a To z
    'amend For other characters If required
    For i = 1 To strlen
        Do
            iTemp = Int((122 - 48 + 1) * Rnd + 48)
            Select Case iTemp
            Case 48 To 57, 65 To 90, 97 To 122: bOK = True
            Case Else: bOK = False
            End Select
        Loop Until bOK = True
        bOK = False
        strTemp = strTemp & Chr(iTemp)
    Next i
    RandomString = strTemp
End Function

Answer 2

太好了！我无法将活动工作簿附加到邮件中。我尝试添加代码 .Attachments.Add（ActiveWorkbook.FullName），但没有成功，我收到一条消息，提示该文件正在使用中，有时会出现运行时错误424-需要对象

With olMail
    .To = "yyy@zzzz.com"
    '.CC = "xxxx@xxx"
    .Subject = "xxxx"
    .Attachments.Add (ActiveWorkbook.FullName) ' this i added

在邮件正文

2 个答案: