【抛砖引玉】在Access中使用微信企业号2 - Office中国论坛/Access中国论坛

'下列常量换成你自己的即可
Public Const Corpid = "wxf4a9ef92f9f6cXXX" '企业Id,可从微信企业号后台获取
Public Const Corpsecret = "FH6346paGvlTOkN5JeU96TltGNmwxcCYUYqvWRm3Q2JVEnVL3egfLYNBLkIf_Aoy" '管理组的凭证密钥
'获取AccessToken,Https请求方式: GET
Private Function GetTokenJson() As String
Dim url As String
Dim ret() As Byte
Dim token As String
url = "https://qyapi.weixin.qq.com/cgi-bin/gettoken?corpid=" & Corpid & "&corpsecret=" & Corpsecret
ret = HttpGet(url)
token = ret
GetTokenJson = token
End Function
'用了个较笨的方法，请自行找个解析JSON的方法替代
Public Function GetToken() As String
Dim tokenJson As String
tokenJson = GetTokenJson
Dim tmp As String
tmp = Split(tokenJson, ",")(0)
tmp = Split(tmp, ":")(1)
tmp = Replace(tmp, """", "")
GetToken = tmp
End Function
'获取发送消息的Json数据
Public Function GetSendTextJson(touser As String, agentid As Integer, content As String) As String
Dim str As String
str = str & "{"
str = str & Replace("""touser"": ""#touser"",", "#touser", touser)
str = str & """msgtype"": ""text"","
str = str & Replace("""agentid"": #agentid,", "#agentid", agentid)
str = str & """text"": {"
str = str & Replace("""content"": ""#content""", "#content", content)
str = str & "},"
str = str & """safe"":0"
str = str & "}"
GetSendTextJson = str
End Function
'发送消息，,Https请求方式: POST
'参数必须说明
'touser 否成员ID列表（消息接收者，多个接收者用‘|’分隔，最多支持1000个）。特殊情况：指定为@all，则向关注该企业应用的全部成员发送
'toparty 否部门ID列表，多个接收者用‘|’分隔，最多支持100个。当touser为@all时忽略本参数
'totag 否标签ID列表，多个接收者用‘|’分隔。当touser为@all时忽略本参数
'msgtype 是消息类型，此时固定为：text
'agentid 是企业应用的id，整型。可在应用的设置页面查看
'content 是消息内容
'safe 否表示是否是保密消息，0表示否，1表示是，默认0
Public Function SendText(token As String, touser As String, agentid As Integer, text As String) As String
Dim url As String
Dim jsonData As String
Dim ret() As Byte
url = "https://qyapi.weixin.qq.com/cgi-bin/message/send?access_token=" & token
jsonData = GetSendTextJson(touser, agentid, text)
Debug.Print jsonData
ret = HttpPost(url, jsonData)
SendText = ret
End Function
Function HttpGet(url As String) As String
Dim xmlHttp As Object
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.3.0")
If Not IsObject(xmlHttp) Then
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.3.0")
If Not IsObject(xmlHttp) Then Exit Function
End If
xmlHttp.Open "GET", url, False
xmlHttp.setRequestHeader "CONTENT-TYPE", "application/json;charset=UTF-8"
xmlHttp.send
Do While xmlHttp.ReadyState <> 4
DoEvents
Loop
Dim ret As String
ret = xmlHttp.responseText
HttpGet = ret
End Function
Function HttpPost(url As String, postMsg As String) As String
Dim xmlHttp As Object
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.3.0")
If Not IsObject(xmlHttp) Then
Set xmlHttp = CreateObject("Msxml2.XMLHTTP.3.0")
If Not IsObject(xmlHttp) Then Exit Function
End If
xmlHttp.Open "POST", url, False
xmlHttp.setRequestHeader "CONTENT-TYPE", "application/Json;charset=UTF-8"
xmlHttp.send (postMsg)
Do While xmlHttp.ReadyState <> 4
DoEvents
Loop
Dim ret As String
ret = xmlHttp.responseText
HttpPost = ret
End Function

复制代码