乐趣区

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

jiezi

在传统行业，用 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
退出移动版