关于vba: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