Excel VBA 的眉眉角角Day26: 將Excel圖表轉存成圖檔後，透過email寄送

DAY 26

Excel VBA 的眉眉角角系列第 26 篇

鐵人賽

Andy Chiu

2014-10-18 08:04:33

18583 瀏覽

分享至

很多時候，Excel產生的報表資料，繪製成精美的圖形後，要寄給長官、同仁看，但有時user並不在座位，只隨身攜帶手機，雖然目前手機也可以直接瀏覽Office檔案，但實在不夠直覺，而且如果只需要將最後結果的圖形資料給user看，那寄一整份的Excel也是浪費空間，這時候，若將圖形轉成圖片檔，再夾給檔給他們，會是更好的選擇。

此外，圖檔的寄送，除了採用email夾檔方式外，還有插入圖片的方式，圖片不在附件中，而是於文件內指定位置插入圖片，若更用心些，加入圖片說明、附註等，呈現效果更佳，以下讓我們來看看程式該如何撰寫：

這個程式可匯出指定工作表內所有的圖形到temp資料夾中

Function ExpChart(shtName As String)
    '匯出指定工作表的圖表為GIF圖片檔
    Dim XlsChart As ChartObject
    
    For Each XlsChart In Worksheets(shtName).ChartObjects
        strFile = Environ("temp") & "\" & XlsChart.Name & ".gif"
        XlsChart.Chart.Export Filename:=strFile, FilterName:="GIF"
    Next
End Function

這個程式用來產生HTML圖片標籤字串，用於插入圖片的效果

Function ChartCID(shtName As String)
    '建立<img src="cid:xxx.gif">的標籤串
    Dim XlsChart As ChartObject
    Dim strChartCID As String
    
    For Each XlsChart In Worksheets(shtName).ChartObjects
        strChartCID = strChartCID & "<b>圖表：" & XlsChart.Name & "</b><BR><img src=""cid:" & XlsChart.Name & ".gif""><BR>"
    Next
    
    ChartCID = strChartCID
End Function

主要程式，用於寄出指定工作表內的圖形內容，可指定使用附件或使用插入圖片方式

Function SendChartByMailUseCDO(shtName As String, bnAddAttachment As Boolean)

    Dim objCDO As Object
    Dim strCfg As String
    Dim stb As Boolean
    Dim dstb As Boolean
    
    Set objCDO = CreateObject("CDO.Message")
    
    strCfg = "http://schemas.microsoft.com/cdo/configuration/"
    
    stb = Application.StatusBar
    dstb = Application.DisplayStatusBar
    
    
    With objCDO
    
    '.Sender = "test@mail.com"
    
    .From = Sheets(shtName).Range("B2")
    
    .To = Sheets(shtName).Range("B3")
    
    '.Fields("urn:schemas:mailheader:X-Priority") = 1 ' Priority = PriorityUrgent 高優先順序
    
    '.Fields("urn:schemas:mailheader:return-receipt-to") = "" ' 要求讀取回條
    
    ' .Fields("urn:schemas:httpmail:importance") = 2 ' Importance = High
    
    ' .Fields("urn:schemas:httpmail:priority") = 1 ' Priority = PriorityUrgent
    
    .Fields.Update ' 更新欄位
    
    .Subject = Sheets(shtName).Range("B4")
    
    ' .TextBody = Sheets(shtName).Range("G4") ' Text 文字格式信件內容
    
    ' 或 HTML 網頁格式信件內容
    '
    ' 如果為插入圖片方式，則透過ChartCID子程式加入
    ' <img src="cid:xxx"> 的CID標示
    If bnAddAttachment = False Then
        .HTMLBody = "<HTML>" & _
                    Sheets(shtName).Range("B5") & _
                    ChartCID(shtName) & _
                    "</HTML>"
        '指定插入圖片物件的實體位置
        For Each XlsChart In Worksheets(shtName).ChartObjects
            Set objBP = objCDO.AddRelatedBodyPart((Environ("temp") & "\" & XlsChart.Name & ".gif"), XlsChart.Name & ".gif", CdoReferenceTypeName)
            objBP.Fields.Item("urn:schemas:mailheader:Content-ID") = "<" & XlsChart.Name & ".gif>"
        Next
        objBP.Fields.Update
    Else
        .HTMLBody = "<HTML>" & _
                    Sheets(shtName).Range("B5") & _
                    "</HTML>"
        Dim i As Integer
        For i = 1 To Worksheets(shtName).ChartObjects.Count
            .AddAttachment Environ("temp") & "\" & Worksheets(shtName).ChartObjects(i).Name & ".gif" ' 附加檔案
        Next i
    
    End If
    .HTMLBodyPart.Charset = "big5"
    
    .CC = Sheets(shtName).Range("B6")  ' 副本
    
    .BCC = Sheets(shtName).Range("B7") ' 密件副本
    
    .Configuration(strCfg & "sendusing") = 2 ' Sendusing = SendUsingPort
    
    .Configuration(strCfg & "smtpserver") = Sheets(shtName).Range("B8")  ' SMTP Server
    
    .Configuration(strCfg & "smtpserverport") = 465 ' SMTP Server Port ( 預設即為 25 )
    
    .Configuration(strCfg & "smtpauthenticate") = 1
    
    .Configuration(strCfg & "smtpusessl") = True
    
    .Configuration(strCfg & "smtpconnectiontimeout") = 60
    
    
    ' SMTP Server 如需登錄 , 則需設定 UserName / Password
    
     .Configuration(strCfg & "sendusername") = Sheets(shtName).Range("B9") ' Send User Name
    
    ' .Configuration(strCfg & "sendpassword") = Sheets(shtName).Range("B10") ' Send Password
    ' 密碼部份暫時改為每次顯示輸入，可依照需求自行修改
    Dim strPassword As String:    strPassword = InputBoxDK("請輸入email密碼：")
     .Configuration(strCfg & "sendpassword") = strPassword
    
    .Configuration.Fields.Update ' 更新 (欄位) 組態
    
'    .DSNOptions = 4 ' 回傳信件傳送狀態, 有以下幾種選擇：
    ' cdoDSNDefault = 0 , DSN commands are issued.
    ' cdoDSNDelay = 8 , Return a DSN if delivery is delayed.
    ' cdoDSNFailure = 2 , Return a DSN if delivery fails.
    ' cdoDSNNever = 1 , No DSNs are issued.
    ' cdoDSNSuccess = 4 , Return a DSN if delivery succeeds.
    ' cdoDSNSuccessFailOrDelay = 14 ,Return a DSN if delivery succeeds, fails, or is delayed.
    
    End With
    
    Application.StatusBar = "Sending.. "
    objCDO.Send ' 傳送
    
    Set objCDO = Nothing
    
    Application.StatusBar = "Done."
    Application.DisplayStatusBar = dstb
    Application.StatusBar = stb

End Function

例如Day26工作表如下：