iT邦幫忙

DAY 26
4

Excel VBA 的眉眉角角系列 第 26

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

很多時候,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工作表如下:

當執行傳送後,會出現輸入e-mail密碼畫面,輸入完成後即可寄出郵件,收到的郵件畫面如下:

使用附件方式:

使用插入圖片方式:

若是執行有異常,請將以下項目引用:


上一篇
Excel VBA 的眉眉角角Day25: 控制pdf檔案產生
下一篇
Excel VBA 的眉眉角角Day27: 匯入外部圖片、縮圖放大以及大頭照的快速裁切方法
系列文
Excel VBA 的眉眉角角30

2 則留言

0
paicheng0111
iT邦研究生 1 級 ‧ 2019-06-03 17:29:27

CdoReferenceTypeName應該設為0還是1

Andy Chiu iT邦研究生 3 級‧ 2019-06-03 21:18:56 檢舉

耶?我沒設定到,不過剛剛測試了一下,0、1都可以正常寄送,只是1的狀態,信內會多了:
「Content-Location: 夾檔完全路徑」的資料,感覺設成0或者不設定都可以

paicheng0111 iT邦研究生 1 級‧ 2019-06-03 21:59:05 檢舉

可能要加個

Const CdoReferenceTypeName = 1

/images/emoticon/emoticon41.gif

Andy Chiu iT邦研究生 3 級‧ 2019-06-04 23:55:54 檢舉

西低,乾蝦!

0
krulolo
iT邦新手 5 級 ‧ 2019-11-03 00:05:31

請問一下 因為我是使用2013 如果引用項目選不到Form 2.0怎辦

Andy Chiu iT邦研究生 3 級‧ 2019-11-03 00:36:09 檢舉

由於還沒用過2013,不知道有無內建Form 2.0,我找了一下,2010版本的有人有問過,可以試試看
Why do I not see the Microsoft Forms 2.0 Object Library?

我要留言

立即登入留言