vba 调用企业微信上传临时素材接口并上传文件

浙江绍兴deng

调用接口是通的，就是写POST语句的时候不知道哪里错了Dim Url As String
Const CorpID As String = "ww08cb8a4e65296616"  '企业在企业微信ID
Dim Secret As String
Dim rs1 As String
Const ErrCode As String = """errcode"":0,""errmsg"":""ok"""
Function Token(CorpID As String, Secret As String) As String
Secret = "kx2z9Tw9w3K6jPXYYZT1CuYyfYRzMjoW7HV7qhJN0nI"    '用于发送消息的应用Secret
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
Sheet1.Cells(1, 7) = Token
'MsgBox (Token)

If InStr(Token, "access_token") > 1 Then
Token = Split(Token, ",")(2)

Token = Split(Token, ":")(1)

Token = Replace(Token, """", "")

Sheet1.Cells(2, 7) = Token
Else
Token = ""
End If
End Function

Function upload()
Dim http
cFile = "C:\Users\dengshaoxin\Desktop\ces.txt"
'cfile = "2.jpg"
tokenstr = Token(CorpID, Secret)
Set http = CreateObject("MSXML2.ServerXMLHTTP")
Sheet1.Cells(3, 7) = tokenstr
Url = "https://qyapi.weixin.qq.com/cgi-bin/media/upload?access_token=" & tokenstr & "&type= image"
http.Open "Post", Url, False
http.setRequestHeader "Content-Type", "multipart/form-data; boundary=-------------------------acebdf13572468"
http.send SendBody(cFile) '发送字串
rs1 = http.responsetext '返回值
If http.Status = 200 Then
rs1 = http.responsetext
End If
MsgBox ("你的返回值" & rs1)
End Function

Function SendBody(ByVal fn As String)
    Dim MyStr As String
    Dim b() As Byte
    Dim StrByte() As Byte
    Dim sLen As Long
     tokenstr = Token(CorpID, Secret)
     MyStr = "POST https://qyapi.weixin.qq.com/cgi-bin/media/upload?access_token=" & tokenstr & "&type=file HTTP/1.1" & vbCrLf
     MyStr = MyStr & "Content-Type: multipart/form-data; boundary=-------------------------acebdf13572468" & vbCrLf
     MyStr = MyStr & "Content-Length: 220" & vbCrLf
     MyStr = MyStr & vbCrLf
     MyStr = MyStr & "---------------------------acebdf13572468" & vbCrLf
     MyStr = MyStr & "Content-Disposition: form-data; name=""media"";filename=""" & fn & """; filelength=6" & vbCrLf
     MyStr = MyStr & "Content-Type: application/octet-stream" & vbCrLf

    StrByte = StrConv(MyStr, vbFromUnicode) '将之前的字符串转为byte
    b = FileToByte(fn) '将要上传的文件转为byte
'    合并字符串及文件成一个byte
    sLen = UBound(StrByte)
    ReDim Preserve StrByte(sLen + UBound(b) - 1)
    For i = 2 To UBound(b)
        StrByte(sLen + i - 1) = b(i)
    Next

    MyStr = MyStr & vbCrLf
    MyStr = MyStr & "mytext" & vbCrLf
    MyStr = MyStr & "---------------------------acebdf13572468--"
  Sheet1.Cells(5, 7) = MyStr
  'Sheet1.Cells(6, 7) = b
  'Sheet1.Cells(7, 7) = MyStr

    b = StrConv(MyStr, vbFromUnicode)
      MsgBox (b)

    sLen = UBound(StrByte)
    ReDim Preserve StrByte(sLen + UBound(b) + 1)
    For i = 0 To UBound(b)
        StrByte(sLen + i + 1) = b(i)
    Next

    SendBody = StrByte
   'MsgBox (StrByte)
End Function
Function FileToByte(ByVal fn As String)
     With CreateObject("adodb.stream")
        .Open
        .LoadFromFile fn
        .Charset = "GB2312"
        .Type = 1
        FileToByte = .Read
        .Close
    End With
End Function

浙江绍兴deng

报44001错误

向東

有没有VBA下载对账单的代码？

zpy2

浙江绍兴deng 发表于 2019-5-23 13:46
报44001错误

https://blog.csdn.net/xuexiaodong009/article/details/83081911
搜到一片可能是拼接字符串的问题，这个用php比较方便的

kingpwfl

同问题，你搞定没？

浙江绍兴deng

kingpwfl 发表于 2019-5-23 15:28
同问题，你搞定没？

还没解决

浙江绍兴deng

向東 发表于 2019-5-23 14:35
有没有VBA下载对账单的代码？

我没有这样的代码，看看其他人有没

kingpwfl

我也搞不清，问题出在那

浙江绍兴deng

Dim Url As String
Const CorpID As String = "微信的ID"  '企业在企业微信ID
Dim Secret As String
Dim rs1 As String
Const ErrCode As String = """errcode"":0,""errmsg"":""ok"""
Function Token(CorpID As String, Secret As String) As String
Secret = "应用的secret"    '用于发送消息的应用Secret
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

If InStr(Token, "access_token") > 1 Then
Token = Split(Token, ",")(2)

Token = Split(Token, ":")(1)

Token = Replace(Token, """", "")

Else
Token = ""
End If
End Function

Function upload()
Dim http
'cfile = "C:\Users\dengshaoxin\Desktop\ces.txt"
cfile = "C:\Users\dengshaoxin\Desktop\2.jpg"
tokenstr = Token(CorpID, Secret)
Set http = CreateObject("MSXML2.ServerXMLHTTP")
Url = "https://qyapi.weixin.qq.com/cgi-bin/media/upload?access_token=" & tokenstr & "&type=file"
http.Open "Post", Url, False
http.setRequestHeader "Content-Type", "multipart/form-data; boundary=-------------------------acebdf13572468"
'http.setRequestHeader "Content-Length", "220"
http.send SendBody(cfile) '发送字串
rs1 = http.responsetext '返回值
If http.Status = 200 Then
rs1 = http.responsetext
End If
MsgBox ("你的返回值" & rs1)
Sheet1.Cells(1, 1) = rs1
End Function

Function SendBody(ByVal fn As String)
    Dim MyStr As String
    Dim b() As Byte
    Dim StrByte() As Byte
    Dim sLen As Long
   
     MyStr = "---------------------------acebdf13572468" & vbCrLf
     MyStr = MyStr & "Content-Disposition: form-data; name=""media"";filename=""" & fn & """" & vbCrLf
     MyStr = MyStr & "Content-Type: application/octet-stream" & vbCrLf
     MyStr = MyStr & vbCrLf
     
    StrByte = StrConv(MyStr, vbFromUnicode) '将之前的字符串转为byte
   
    b = FileToByte(fn) '将要上传的文件转为byte
'    合并字符串及文件成一个byte
    sLen = UBound(StrByte)
    ReDim Preserve StrByte(sLen + UBound(b) - 1)
    For i = 2 To UBound(b)
        StrByte(sLen + i - 1) = b(i)
    Next
   
    MyStr = vbCrLf & "---------------------------acebdf13572468--"
    MyStr = MyStr & vbCrLf
   
    b = StrConv(MyStr, vbFromUnicode)
    sLen = UBound(StrByte)
    ReDim Preserve StrByte(sLen + UBound(b) + 1)
    For i = 0 To UBound(b)
        StrByte(sLen + i + 1) = b(i)
    Next
    SendBody = StrByte

End Function
Function FileToByte(ByVal fn As String)
     With CreateObject("adodb.stream")
        .Open
        .LoadFromFile fn
        .Charset = "GB2312"
        .Type = 1
        FileToByte = .Read
        .Close
    End With
End Function

浙江绍兴deng

我已经搞定了，代码上传中