12.5 Excel里VBA发送https请求

vieyahn2017 commented 3 years ago

VBA发送https请求

vieyahn2017 commented 3 years ago

第一版 http ，处理https有遇到证书错误

' 证书错误
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Set HttpReq = CreateObject("MSXML2.ServerXMLHTTP")
    baseUrl = "https://***"
    URL = baseUrl & "/As/31000051511111251222"
    HttpReq.Open "GET", URL, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    HttpReq.setRequestHeader "Content-Type", "application/VIID+JSON"
    HttpReq.setRequestHeader "token", "0FACD664F75F4AF880C57F80362275F1"
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send

    strResponse = StrConv(HttpReq.responsebody, vbUnicode, &H804)
    MsgBox strResponse

End Sub

vieyahn2017 commented 3 years ago

新版的，测试成功

' 测试成功，可以发送https
Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    baseUrl = "https://***"
    URL = baseUrl & "/As/31000051511111251222"

    HttpReq.Option(4)=13506
    HttpReq.Open "GET", URL, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    HttpReq.setRequestHeader "Content-Type", "application/VIID+JSON"
    HttpReq.setRequestHeader "token", "0FACD664F75F4AF880C57F80362275F1"
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send

    strResponse = HttpReq.responsetext
    MsgBox strResponse

End Sub

vieyahn2017 commented 3 years ago

封装的restful请求基础方法


Public g_HOST As String  ' 环境ip
Public g_BASE_URL As String  ' https://5.4.3.2/testhome/
Public g_TOKEN As String '  登录用户的token
Public g_TOKEN_AVAILABLE As Boolean '  登录用户的token是否可用

Function g_MY_https_doGet(url)
    on_debug = False
    If on_debug Then
        g_TOKEN = Sheets("Login").Cells(9, 2).value
        g_HOST = Sheets("Login").Cells(1, 2).value
        g_BASE_URL = "https://" & g_HOST & "/testhome/"
    Else
        If Not g_TOKEN_AVAILABLE Then
            'g_MY_https_doGet = "token过期，请重新登录"
            If ActiveSheet.Name <> "Login" Then
                Sheets("Login").Activate
            End If
            Exit Function
        End If
    End If
    token = g_TOKEN

    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpReq.Option(4) = 13056     ' ignore error
    HttpReq.Open "GET", g_BASE_URL & url, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    HttpReq.setRequestHeader "Content-Type", "application/JSON"
    HttpReq.setRequestHeader "token", token
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send

    response = HttpReq.ResponseText

    Log2Sheet "GET", url, response

    If InStr(response, "Invalid Operation@Login expired.") <> 0 Then
        g_TOKEN_AVAILABLE = False
        'Sheets("Login").Activate
        Exit Function
    End If

    g_MY_https_doGet = response
End Function

Function g_MY_https_doDelete(url, Optional data = "{}")
    on_debug = False
    If on_debug Then
        g_TOKEN = Sheets("Login").Cells(9, 2).value
        g_HOST = Sheets("Login").Cells(1, 2).value
        g_BASE_URL = "https://" & g_HOST & "/testhome/"
    Else
        If Not g_TOKEN_AVAILABLE Then
            'g_MY_https_doDelete = "token过期，请重新登录"
            If ActiveSheet.Name <> "Login" Then
                Sheets("Login").Activate
            End If
            Exit Function
        End If
    End If
    token = g_TOKEN

    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpReq.Option(4) = 13056     ' ignore error
    HttpReq.Open "DELETE", g_BASE_URL & url, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    HttpReq.setRequestHeader "Content-Type", "application/JSON"
    HttpReq.setRequestHeader "token", token
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send data

    If on_debug Then
        'MsgBox HttpReq.ResponseText
    End If

    response = HttpReq.ResponseText

    Log2Sheet "DELETE", url, response

    If InStr(response, "Invalid Operation@Login expired.") <> 0 Then
        g_TOKEN_AVAILABLE = False
        Sheets("Login").Activate
        Exit Function
    End If

    g_MY_https_doDelete = response
End Function

Function g_MY_https_doPost(url, data)
    on_debug = False
    If on_debug Then
        g_TOKEN = Sheets("Login").Cells(9, 2).value
        g_HOST = Sheets("Login").Cells(1, 2).value
        g_BASE_URL = "https://" & g_HOST & "/testhome/"
    Else
        If Not g_TOKEN_AVAILABLE Then
            'g_MY_https_doPost = "token过期，请重新登录"
            If ActiveSheet.Name <> "Login" Then
                Sheets("Login").Activate
            End If
            Exit Function
        End If
    End If
    token = g_TOKEN

    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpReq.Option(4) = 13056     ' ignore error
    HttpReq.Open "POST", g_BASE_URL & url, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    ' 真尼玛坑，单独设置application/JSON，会被vba转换成 "application/JSON; Charset=UTF-8" 多了一个空格，导致viid后台校验通不过，报错 "71401001", "Invalid request header"
    HttpReq.setRequestHeader "Content-Type", "application/JSON;charset=UTF-8"
    HttpReq.setRequestHeader "token", token
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send data

    If on_debug Then
        'MsgBox HttpReq.ResponseText
    End If

    Log2Sheet "POST", url, HttpReq.ResponseText

    g_MY_https_doPost = HttpReq.ResponseText
End Function

Function g_MY_https_doPut(url, data)
    on_debug = False
    If on_debug Then
        g_TOKEN = Sheets("Login").Cells(9, 2).value
        g_HOST = Sheets("Login").Cells(1, 2).value
        g_BASE_URL = "https://" & g_HOST & "/testhome/"
    Else
        If Not g_TOKEN_AVAILABLE Then
            'g_MY_https_doPost = "token过期，请重新登录"
            If ActiveSheet.Name <> "Login" Then
                Sheets("Login").Activate
            End If
            Exit Function
        End If
    End If
    token = g_TOKEN

    Set HttpReq = CreateObject("WinHttp.WinHttpRequest.5.1")
    HttpReq.Option(4) = 13056     ' ignore error
    HttpReq.Open "PUT", g_BASE_URL & url, False
    HttpReq.setRequestHeader "User-Agent", "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.0)"
    ' 真尼玛坑，单独设置application/JSON，会被vba转换成 "application/JSON; Charset=UTF-8" 多了一个空格，导致viid后台校验通不过，报错 "71401001", "Invalid request header"
    HttpReq.setRequestHeader "Content-Type", "application/JSON;charset=UTF-8"
    HttpReq.setRequestHeader "token", token
    HttpReq.setRequestHeader "User-Identify", "1"
    HttpReq.Send data

    If on_debug Then
        'MsgBox HttpReq.ResponseText
    End If

    response = HttpReq.ResponseText

    Log2Sheet "PUT", url, response

    If InStr(response, "Invalid Operation@Login expired.") <> 0 Then
        g_TOKEN_AVAILABLE = False
        Sheets("Login").Activate
        Exit Function
    End If

    g_MY_https_doPut = response
End Function

Sub Log2Sheet(method, url, response)
    With Sheets("logs")
        last_row = .UsedRange.Rows.Count
        log_row = last_row + 1

        .Cells(log_row, 1) = Format(Now, "yyyy-mm-dd hh:mm:ss")
        .Cells(log_row, 2) = method
        .Cells(log_row, 3) = url
        .Cells(log_row, 4) = response

        .Cells(log_row, 4).WrapText = False  '去掉自动换行
    End With
End Sub

vieyahn2017 commented 3 years ago

VBA解析JSON数据（3）--JavaScript

https://blog.csdn.net/taller_2000/article/details/87693976

VBA解析JSON数据（4）--JavaScript进阶

https://blog.csdn.net/taller_2000/article/details/87798344

Vba实现解析json数据

https://www.cnblogs.com/gxgd/p/9240232.html Vba实现解析json数据。当中的关于Set oSC = CreateObject("MSScriptControl.ScriptControl") 不能创建对象的问题。这几天在word里面写宏，想解析服务器传过来的json串。但是Set oSC = CreateObjectx86("MSScriptControl.ScriptControl")这个方法一直创建不了对象。

最后再网上看到说，word分为32位的和64位的这个方法只有在32位的word里面才可以使用，在64位的里面是实现不了的（不能创建对象）

[VBA] 接收和解析 JSON

64位Excel解析JSON时需要加入一个模块, 模块名可以起为Convert64To32，模块中填入：


Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    Static oWnd As Object
    Dim bRunning As Boolean
    #If Win64 Then
        bRunning = InStr(TypeName(oWnd), "HTMLWindow") > 0
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    #End If
End Function

Function CreateWindow()
    Dim sSignature, oShellWnd, oProc
    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
        Next
    Loop
End Function

vieyahn2017 commented 3 years ago

但是上面的代码有兼容性问题，某些环境运行不了就卡死

我做了修改适配


Function CreateObjectx86(Optional sProgID, Optional bClose = False)
    Static oWnd As Object
    Dim bRunning As Boolean
    #If Win64 Then
        bRunning = InStr(typeName(oWnd), "HTMLWindow") > 0   ' TRUE    HTMLWindow2  ' FALSE   Nothing
        If bClose Then
            If bRunning Then oWnd.Close
            Exit Function
        End If
        If Not bRunning Then
            Set oWnd = CreateWindow()
            oWnd.execScript "Function CreateObjectx86(sProgID): Set CreateObjectx86 = CreateObject(sProgID): End Function", "VBScript"
        End If
        Set CreateObjectx86 = oWnd.CreateObjectx86(sProgID)
    #Else
        Set CreateObjectx86 = CreateObject("MSScriptControl.ScriptControl")
    #End If
End Function

Function CreateWindow()
    Dim sSignature, oShellWnd, oProc
    Dim ErrCount As Integer
    ErrCount = 0
    On Error Resume Next
    sSignature = Left(CreateObject("Scriptlet.TypeLib").GUID, 38)
    CreateObject("WScript.Shell").Run "%systemroot%\syswow64\mshta.exe about:""about:<head><script>moveTo(-32000,-32000);document.title='x86Host'</script><hta:application showintaskbar=no /><object id='shell' classid='clsid:8856F961-340A-11D0-A96B-00C04FD705A2'><param name=RegisterAsBrowser value=1></object><script>shell.putproperty('" & sSignature & "',document.parentWindow);</script></head>""", 0, False
    Do
        For Each oShellWnd In CreateObject("Shell.Application").Windows
            Set CreateWindow = oShellWnd.GetProperty(sSignature)
            If Err.Number = 0 Then Exit Function
            Err.Clear
            ErrCount = ErrCount + 1
        Next

        If ErrCount > 100 Then  ' 不让死循环挂起  ' 正常情况上面的For一次执行就成功退出了。在个别环境遇到了一直取不到值从而卡死的情况
            Log2Sheet "CreateWindow", Err.Description, sSignature
            Exit Function
        End If
    Loop
End Function

vieyahn2017 commented 3 years ago

解析json 示例代码


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

    Dim delOperColumn As Integer  ' 数据列的下一列：操作[删除]
    delOperColumn = 6
    url = "AXSs"
    ListObjectObjectName = "AXSListObject.AXSObject"
    g_sheet_Object = Sheets("Config").Cells(6, 2).value

    If ActiveCell.Column = 5 And ActiveCell.Row = 1 Then  ' 查询

        msg = checkSelectParams
        If Not msg = "" Then
            MsgBox msg
            Exit Sub
        End If

        getUrl = makeQueryParams(url)
        response = g_MY_https_doGet(getUrl)
        parseJSON response, ListObjectObjectName, delOperColumn

        Exit Sub
    End If

End Sub

Function parseJSON(strJSON, ListObjectObjectName, delete_oper_column, Optional start_line As Integer = 21)
    ' 本方法' parseJSON 大部分对象可以通用，小部分对象可能需要单独处理
    If strJSON = "" Then
        ' MsgBox "https请求返回为空，请检查"
        Exit Function
    End If

    On Error GoTo JsonErr

    Dim objJS As Object
    Dim strJSCode As String
    ' 网贴的方法 CreateObject("MSScriptControl.ScriptControl")创建失败， 有帖子说该方法只支持32位
    Set objJS = CreateObjectx86("MSScriptControl.ScriptControl")
    objJS.Language = "javascript"
    strJSCode = "var json = " & strJSON & ";"
    objJS.AddCode (strJSCode)

    ResponseStatusObject = objJS.Eval("json." & "ResponseStatusObject")   ' 查询为空的时候返回ResponseStatusObject

    If ResponseStatusObject <> "" Then
        MsgBox "查询数据为空"
        Exit Function
    End If

    objListLength = objJS.Eval("json." & ListObjectObjectName & ".length")

    With ActiveSheet

        last_data_line = .UsedRange.Rows.Count
        If last_data_line <= start_line Then
            last_data_line = start_line
        End If

        .Range(.Cells(start_line, 1), .Cells(last_data_line, delete_oper_column)).Select
        With Selection.Interior
            .Pattern = xlNone
        End With

        Selection.ClearContents

        .Range(.Cells(start_line, 1), .Cells(start_line + objListLength - 1, delete_oper_column)).Select
        Selection.NumberFormatLocal = "@"

        For i = 0 To objListLength - 1
            objJS.Eval ("var item=json." & ListObjectObjectName & "[" & i & "]")

            j = start_line + i
            For k = 1 To delete_oper_column - 1  '对象的取值，对应表格的第20行
                key = .Cells(start_line - 1, k).value
                keyval = objJS.Eval("item." & key)

                If key = "IsOnline" Then
                    .Cells(j, k).value = g_Fun_ParseSelectValue(keyval, key)
                Else
                     .Cells(j, k).value = keyval
                End If
            Next

            .Cells(j, k).value = "删除"
        Next

    End With

    Set objJS = Nothing
    Exit Function

JsonErr:
    MsgBox "数据转换异常，请检查" & Err.Description & vbCrLf & strJSON

End Function

vieyahn2017 / iBlog