Excel VBA通过企业微信群机器人发送工作表区域截图

在传统行业，用Excel做表比通过Python操作更加普遍，Excel也可以通过VBA实现报表自动化：自动更新数据，用公式/代码生成点评，通过Outlook自动群发邮件，嵌入代码的xlsm可以直接发送给其他人使用，无需打包成exe...于是企微机器人传值这种Python几行代码的事情也只能捏着鼻子上那么一百几十行VBA了。

本文代码解决流程中3个主要步骤：

1. 将Excel工作表的指定区域保存为图片
2. 获取保存的图片的MD5和Base64
3. 将MD5和Base64组成json格式发送企微提供的Webhook

（一）保存图片示例代码

保存的图片有可能为空白，可以增加文件大小校验。

Public Function RangeToPic(Rng As Range)
    '使用当前文件所在路径作为输出路径    
    Pth = ActiveWorkbook.Path
    '使用【文件名_区域地址】作为输出文件名
    Pnm = Left(ActiveWorkbook.Name, InStrRev(ActiveWorkbook.Name, ".") - 1) & "_" & Replace(Rng.Address(0, 0), ":", "_")
    
    '把选择范围内容转化为截屏图片信息
    Rng.CopyPicture Appearance:=xlScreen, Format:=xlBitmap
    With ActiveSheet.ChartObjects.Add(0, 0, Rng.Width + 1, Rng.Height + 1).Chart
        .ChartArea.Border.LineStyle = 0
        .Parent.Select
        .Paste
        .Export Pth & "\" & Pnm & ".png", "PNG"
        .Parent.Delete
    End With
End Function

（二）用VBA获取文件MD5

建议封装为模块，调用MD5File(文件路径)

Option Explicit
Type MD5_CTX
      dwNUMa      As Long
      dwNUMb      As Long
      Buffer(15)  As Byte
      cIN(63)     As Byte
      cDig(15)    As Byte
End Type

Private Declare PtrSafe Sub MD5Init Lib "advapi32" (lpContext As MD5_CTX)
Private Declare PtrSafe Sub MD5Final Lib "advapi32" (lpContext As MD5_CTX)
Private Declare PtrSafe Sub MD5Update Lib "advapi32" (lpContext As MD5_CTX, ByRef lpBuffer As Any, ByVal BufSize As Long)
Private stcContext   As MD5_CTX

'计算一个字符串（ANSI编码）的MD5码：输入字符串文本，返回MD5码（16字节的Byte数组）
Public Function MD5String(strText As String) As Byte()
    Dim aBuffer() As Byte
    Call MD5Init(stcContext)
    If (Len(strText) > 0) Then
        aBuffer = StrConv(strText, vbFromUnicode)
        Call MD5Update(stcContext, aBuffer(0), UBound(aBuffer) + 1)
    Else
        Call MD5Update(stcContext, 0, 0)
    End If
    Call MD5Final(stcContext)
    MD5String = stcContext.cDig
End Function

'计算一个字节流的MD5码：输入Byte数组和长度（可选，默认计算整个长度），返回MD5码 （16字节的Byte数组）
Public Function MD5Bytes(Buffer() As Byte, _
    Optional ByVal size As Long = -1) As Byte()
    Dim U As Long, pBase As Long
    
    pBase = LBound(Buffer)
    U = UBound(Buffer) - pBase
    If (-1 = size) Then size = U + 1
        Call MD5Init(stcContext)
    If (-1 = U) Then
        Call MD5Update(stcContext, 0, 0)
    Else
        Call MD5Update(stcContext, Buffer(pBase), size)
    End If
    Call MD5Final(stcContext)
    MD5Bytes = stcContext.cDig
End Function

'计算一个文件的MD5码：输入磁盘文件名（完整路径），返回MD5码 （16字节的Byte数组）
Public Function MD5File(ByVal FileName As String) As Byte()
    Const BUFFERSIZE  As Long = 1024& * 512      ' 缓冲区 512KB
    Dim DataBuff() As Byte
    Dim lFileSize  As Long
    Dim iFn        As Long
    
    On Error GoTo E_Handle_MD5
    If (Len(Dir$(FileName)) = 0) Then Err.Raise 5      '文件不存在
    
    ReDim DataBuff(BUFFERSIZE - 1)
    iFn = FreeFile()
    Open FileName For Binary As #iFn
    lFileSize = LOF(iFn)
    Call MD5Init(stcContext)
    
    If (lFileSize = 0) Then
        Call MD5Update(stcContext, 0, 0)
    Else
        Do While (lFileSize > 0)
            Get iFn, , DataBuff
            If (lFileSize > BUFFERSIZE) Then
                Call MD5Update(stcContext, DataBuff(0), BUFFERSIZE)
            Else
                Call MD5Update(stcContext, DataBuff(0), lFileSize)
            End If
            lFileSize = lFileSize - BUFFERSIZE
        Loop
    End If
    Close iFn
    Call MD5Final(stcContext)
E_Handle_MD5:
    MD5File = stcContext.cDig
End Function

（三）用VBA获取图片Base64

调用EncodeFilebase64(文件路径)

Public Function EncodeFilebase64(strPicPath As String) As String
    Dim PicExtn As String, FLPath As String
    Dim StrPath As Variant
    Dim BSC As Long
    Dim fso As Object
    PicExtn = Split(strPicPath, ".")(1)
    '返回没有换行符的base64值
    FLPath = Replace(strPicPath, PicExtn, ".txt")
    EncodeFilebase64 = Replace(EncodeFile(strPicPath), Chr(10), "")
End Function

Public Function EncodeFile(strPicPath As String) As String
    Const adTypeBinary = 1
    Dim objXML
    Dim objDocElem
    Dim objStream

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = adTypeBinary
    objStream.Open
    objStream.LoadFromFile (strPicPath) 
    Set objXML = CreateObject("MSXml2.DOMDocument")
    Set objDocElem = objXML.createElement("Base64Data")
    
    objDocElem.DataType = "bin.base64"
    objDocElem.nodeTypedValue = objStream.Read()
    EncodeFile = objDocElem.text

    Set objXML = Nothing
    Set objDocElem = Nothing
    Set objStream = Nothing
End Function

（四）通过VBA调用企业微信群机器人

将图片组建成json格式传值给机器人函数，然后直接发送

Public Function BotPic(Picname As String, url As String, Optional PicPth As String) As String
    Dim params As String, ibase64 As String, imd5 As String
    Dim strPicPath As String
    
    '输入的PicPth为空则使用当前文件所在路径作为路径
    If PicPth = "" Then PicPth = ActiveWorkbook.Path
    strPicPath = PicPth & "\" & Picname & ".jpg"
    
    '获取base64转码
    ibase64 = EncodeFilebase64(strPicPath)
    
    '获取MD5转码
    Call MD5File(strPicPath)
    imd5 = LCase(GetMD5Text())
    
    '发送内容构建成json格式
    para1 = "{""msgtype"":""image"",""image"":{""base64"":"""
    para2 = """,""md5"":"""
    para3 = """}}"
    params = para1 & ibase64 & para2 & imd5 & para3

    BotPic = HttpRequest(url, "POST", params)
End Function