|
|
下面代码可以正常使用，发送微信。
发送机制：
第一步：企业的CorpID + 企业的Secret 换取 Token
第二步：用Token 给 微信ID(不是姓名)发送消息
使用方法：
1 复制代码到 VBA模块
2 改代码中 "微信的Secret" 和 "微信的CorpID" 为自己公司的 就可以了
Dim Url As String
Const CorpID As String = "微信的CorpID"
Const Secret As String = "微信的Secret"
Const SendText As String = "{""touser"": ""成员ID"",""toparty"": ""部门ID"",""totag"": ""标签ID"",""msgtype"": ""text"",""agentid"": 0,""text"": {""content"": ""消息内容""},""safe"":0}"
Const ErrCode As String = """errcode"":0,""errmsg"":""ok"""
Function Token(CorpID As String, Secret As String) As String
'获取Token 提醒一天只能获取 2000次，最好获取后保存方便调用
Dim http
Set http = CreateObject("MSXML2.ServerXMLHTTP")
Url = "https://qyapi.weixin.qq.com/cgi-bin/gettoken?corpid=" & CorpID & "&corpsecret=" & Secret
http.Open "get", Url, False 'post get 都可以
http.send ""
If http.Status = 200 Then
Token = http.responseText
End If
'Debug.Print Token
'分解
If InStr(Token, "access_token") > 1 Then
Token = Split(Token, ",")(0)
Token = Split(Token, ":")(1)
Token = Replace(Token, """", "")
Else
Token = ""
End If
End Function
Sub te()
获取Token方法
Str1 = Token(CorpID, Secret)
Debug.Print Str1
end Sub
Function SendMsg(发送文本 As String) As String
'发消息
Dim http
TokenStr=Token(CorpID, Secret)
Set http = CreateObject("MSXML2.ServerXMLHTTP")
Url = "https://qyapi.weixin.qq.com/cgi-bin/message/send?access_token=" & TokenStr
http.Open "Post", Url, False
http.send 发送文本
If http.Status = 200 Then
SendMsg = http.responseText
End If
'If InStr(SendMsg, ErrCode) = 0 Then MsgBox "错误：" & SendMsg
End Function
Sub te()
'发送文本 替换名字 部门 消息
Str1 = Replace(SendStr, "成员ID", "自己的成员微信ID")
Str1 = Replace(Str1, "部门ID", "自己的部门")
Str1 = Replace(Str1, "标签ID", "自己的标签")
Str1 = Replace(Str1, "消息内容", "自己的发送文本")
'发送消息
Str1 =SendMsg(Str1 )
end Sub
上面的代码可以发信息了。我们一般只知道名字不知道微信ID，下面的代码可以提取微信的成员信息生成数据表，方便查找。
Sub GetWxUers()
'获取微信成员 这个办法很笨 josn高级这里总出错不会用
Dim http
Dim MyArr, MyArr1
Dim i1 As Integer, i2 As Integer, Str1 As String, Str2 As String
TokenStr=Token(CorpID, Secret)
Set http = CreateObject("MSXML2.ServerXMLHTTP")
Url = "https://qyapi.weixin.qq.com/cgi-bin/user/list?access_token=" & TokenStr & "&department_id=1&fetch_child=1&status=0"
http.Open "Get", Url, False
http.send ""
If http.Status = 200 Then
Str1 = http.responseText
End If
If InStr(Str1, ErrCode) = 0 Then MsgBox "错误：" & Str1: Exit Sub
'删除头信息
Str1 = Split(Str1, "[{")(1)
'排除http：中的：
Str1 = Replace(Str1, """:", "|")
Str1 = Replace(Str1, "/", "")
'去掉最后一个
Str1 = Replace(Str1, "}", "")
Sql = ""
'个人信息分条
MyArr = Split(Str1, ",{")
For i = 0 To UBound(MyArr)
'个人 列信息
MyArr1 = Split(MyArr(i), ",""")
Str1 = "": Str2 = ""
For i1 = 0 To UBound(MyArr1)
Str1 = Str1 & "[" & Split(MyArr1(i1), "|")(0) & "],"
Str2 = Str2 & "'" & Split(MyArr1(i1), "|")(1) & "',"
Next
'去掉最后一个字母，
Str1 = Left(Str1, Len(Str1) - 1)
Str2 = Left(Str2, Len(Str2) - 1)
'去掉部门中的[]
Str2 = Replace(Str2, "[", "")
Str2 = Replace(Str2, "]", "")
'生成SQL插入语句
Sql = Sql & " INSERT into [users] (" & Str1 & ") Values (" & Str2 & ")"
Sql = Replace(Sql, """", "")
Next
‘’生成sql插入表
Set ConnWy = Conn("自己的数据库连接代码")
ConnWy.Execute ("delete from [users] ")
ConnWy.Execute (Sql)
ConnWy.Close
End Sub
还可以通过task定时打开excel文件，实现定时自动发送提醒消息。
补充内容 (2019-2-25 15:12):
获取微信成员代码已更新，见27楼
补充内容 (2019-7-31 09:58):
38楼有附件 |
评分
-
3
查看全部评分
-
|
[复制链接]
/1 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2017-1-19 15:46
