VBA MACRO：尝试编辑返回 json 数据的 VBA 宏 [关闭]

Question

请参阅下面的代码，该代码可用于查询 api 调用。我展示了仅从 json 中提取特定项目。返回了更多信息，例如所有当前可以超过1的工作。如何修改代码以按状态查询？

Option Explicit
'Individual
Public r As Long

Public Sub GetListings2()
    '<  VBE > Tools > References > Microsoft Scripting Runtime
    Dim json As Object, apiUrl As String, re As Object, s As String, latLon()
    r = 0
    Set re = CreateObject("VBScript.RegExp")
    apiUrl = "https://api.brokercheck.finra.org/individual?hl=true&includePrevious=false&json.wrf=angular.callbacks._d&lat={LAT}&lon={LON}&nrows=100&r=25&sort=score+desc&{START}&wt=json"
    Dim xhr As Object, totalResults As Long, numPages As Long

    Set xhr = CreateObject("MSXML2.XMLHTTP")

    latLon = GetLatLon("30047", xhr, re)
    apiUrl = Replace$(Replace$(apiUrl, "{LAT}", latLon(0)), "{LON}", latLon(1))
    s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=0"), re)

    If s = "No match" Then Exit Sub

    Set json = JsonConverter.ParseJson(s)("hits")

    totalResults = json("total")

    numPages = Application.RoundUp(totalResults / 100, 0)

    Dim results(), ws As Worksheet, headers(), i As Long

    'example info retrieved. There is a lot more info in json
    headers = Array("CRD Number Indiv", "Name", "FINRA registered", "Disclosures", "In industry since")
    ReDim results(1 To totalResults, 1 To UBound(headers) + 1)

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    results = GetIndividualListings(results, json("hits"))
    If numPages > 1 Then
        For i = 2 To numPages
            DoEvents
            s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=" & (i - 1) * 100), re)
            If s = "No match" Or InStr(s, "Exceeded limit") > 0 Then Exit For
            Set json = JsonConverter.ParseJson(s)("hits")
            results = GetIndividualListings(results, json("hits"))
        Next
    End If
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetLatLon(ByVal zip As String, ByVal xhr As Object, ByVal re As Object) As Variant
    Dim json As Object, lat As String, lon As String
    With xhr
        .Open "GET", Replace$("https://api.brokercheck.finra.org/locations?query={ZIP}&results=1", "{ZIP}", zip), False 'changed results = 10 to results = 1
        .send
        Set json = JsonConverter.ParseJson(.responseText)("hits")("hits")(1)("_source")
        lat = json("latitude")
        lon = json("longitude")
        GetLatLon = Array(lat, lon)
    End With
End Function

Public Function GetApiResults(ByVal xhr As Object, ByVal apiUrl As String, ByVal re As Object) As String
    With xhr
        .Open "GET", apiUrl, False
        .send
        GetApiResults = GetJsonString(re, .responseText)
    End With
End Function

Public Function GetIndividualListings(ByVal results As Variant, ByVal json As Object) As Variant
    Dim row As Object
      'can have numerous current employments. Alter here and below if want more info from json about the individual

    For Each row In json
        r = r + 1
        results(r, 1) = row("_source")("ind_source_id")
        results(r, 2) = Replace$(Join$(Array(row("_source")("ind_firstname"), row("_source")("ind_middlename"), row("_source")("ind_lastname")), ", "), ", , ", ", ")
        results(r, 3) = row("_source")("ind_approved_finra_registration_count")
        results(r, 4) = row("_source")("ind_bc_disclosure_fl")
        results(r, 5) = row("_source")("ind_industry_cal_date")
    Next
    GetIndividualListings = results
End Function

Public Function GetJsonString(ByVal re As Object, ByVal responseText As String) As String
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\((.*)\);" 'regex pattern to get json string
        If .Test(responseText) Then
            GetJsonString = .Execute(responseText)(0).SubMatches(0)
        Else
            GetJsonString = "No match"
        End If
    End With
End Function

结果有效，但查询如何更改为查询状态而不是邮政编码？

Answer 1

简而言之：

手动请求Individual by State和Firm by State，并通过开发工具F12观察网络流量。在网络选项卡中，您将看到每个 API 调用，并观察 API 调用中的附加参数 state；并且angular 回调标识符发生了变化。 API 调用返回 json，在 Firm by State 的情况下，需要您更改 json 解析的路径才能获取本地办公室。

---

tl;dr

您只需将 state 参数添加到 url 的 queryString 中。然后使用的值是状态的大写2 letter code，例如路易斯安那州=洛杉矶。角度回调标识符也会更改以反映使用状态。

仍然以洛杉矶为例....

个人的API调用变为：

https://api.brokercheck.finra.org/individual?hl=true&includePrevious=true&json.wrf=angular.callbacks._0&nrows=100&r=25&sort=score+desc&state=LA&wt=json

对于公司来说：

https://api.brokercheck.finra.org/firm?hl=true&json.wrf=angular.callbacks._1&nrows=100&r=25&sort=score+desc&state=LA&wt=json

---

各州公司

firm by state 的重写示例如下：

_{注意：这会提取第一个本地办公室地址，尽管主要办公室在json 中可用。你也不再需要LatLon。}

Option Explicit
'Firm by state
Public r As Long

Public Sub GetListings()
    '<  VBE > Tools > References > Microsoft Scripting Runtime
    Dim json As Object, apiUrl As String, re As Object, s As String, state As String
    state = "LA"
    r = 0
    Set re = CreateObject("VBScript.RegExp")
    apiUrl = "https://api.brokercheck.finra.org/firm?hl=true&json.wrf=angular.callbacks._1&nrows=100&r=25&sort=score+desc&{START}&state={STATE}&wt=json"
    Dim xhr As Object, totalResults As Long, numPages As Long

    Set xhr = CreateObject("MSXML2.XMLHTTP")
    apiUrl = Replace$(apiUrl, "{STATE}", state)
    s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=0"), re)

    If s = "No match" Then Exit Sub

    Set json = JsonConverter.ParseJson(s)("hits")

    totalResults = json("total")

    numPages = Application.RoundUp(totalResults / 100, 0)

    Dim results(), ws As Worksheet, headers(), i As Long
    ReDim results(1 To totalResults, 1 To 3)
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = Array("CRD Number", "Name", "Address")
    results = GetFirmListings(results, json("hits"))

    If numPages > 1 Then
        For i = 2 To numPages
            s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=" & (i - 1) * 100), re)
            If s = "No match" Or InStr(s, "Exceeded limit") > 0 Then Exit For
            Set json = JsonConverter.ParseJson(s)("hits")
            results = GetFirmListings(results, json("hits"))
        Next
    End If
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetApiResults(ByVal xhr As Object, ByVal apiUrl As String, ByVal re As Object) As String
    With xhr
        .Open "GET", apiUrl, False
        .send
        GetApiResults = GetJsonString(re, .responseText)
    End With
End Function

Public Function GetFirmListings(ByVal results As Variant, ByVal json As Object) As Variant
    Dim row As Object

    For Each row In json
        r = r + 1  'Crd number, name and local office address (not main branch)
        results(r, 1) = row("_source")("firm_source_id")
        results(r, 2) = row("_source")("firm_name")
        results(r, 3) = Join$(row("inner_hits")("branchOfficeLocations")("hits")("hits")(1)("_source").items, ", ")
    Next
    GetFirmListings = results
End Function

Public Function GetJsonString(ByVal re As Object, ByVal responseText As String) As String
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\((.*)\);" 'regex pattern to get json string
        If .test(responseText) Then
            GetJsonString = .Execute(responseText)(0).SubMatches(0)
        Else
            GetJsonString = "No match"
        End If
    End With
End Function

---

各州个人：

Option Explicit
'Individual by state
Public r As Long

Public Sub GetListings2()
    '<  VBE > Tools > References > Microsoft Scripting Runtime
    Dim json As Object, apiUrl As String, re As Object, s As String, state As String
    r = 0
    state = "LA"
    Set re = CreateObject("VBScript.RegExp")
    apiUrl = "https://api.brokercheck.finra.org/individual?hl=true&includePrevious=true&json.wrf=angular.callbacks._0&nrows=100&r=25&sort=score+desc&{START}&state=LA&wt=json"
    Dim xhr As Object, totalResults As Long, numPages As Long

    Set xhr = CreateObject("MSXML2.XMLHTTP")
    apiUrl = Replace$(apiUrl, "{STATE}", state)
    s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=0"), re)

    If s = "No match" Then Exit Sub

    Set json = JsonConverter.ParseJson(s)("hits")

    totalResults = json("total")

    numPages = Application.RoundUp(totalResults / 100, 0)

    Dim results(), ws As Worksheet, headers(), i As Long

    'example info retrieved. There is a lot more info in json
    headers = Array("CRD Number Indiv", "Name", "FINRA registered", "Disclosures", "In industry since", _
                    "Employer CRD", "Employer Name", "Employer City", "Employer State", "Employer Zip")
    ReDim results(1 To totalResults, 1 To UBound(headers) + 1)

    Set ws = ThisWorkbook.Worksheets("Sheet1")

    results = GetIndividualListings(results, json("hits"))
    If numPages > 1 Then
        For i = 2 To numPages
            DoEvents
            s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=" & (i - 1) * 100), re)
            If s = "No match" Or InStr(s, "Exceeded limit") > 0 Then Exit For
            Set json = JsonConverter.ParseJson(s)("hits")
            results = GetIndividualListings(results, json("hits"))
        Next
    End If
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Sub GetListings()
    '<  VBE > Tools > References > Microsoft Scripting Runtime
    Dim json As Object, apiUrl As String, re As Object, s As String, state As String
    state = "LA"
    r = 0
    Set re = CreateObject("VBScript.RegExp")
    apiUrl = "https://api.brokercheck.finra.org/firm?hl=true&json.wrf=angular.callbacks._1&nrows=100&r=25&sort=score+desc&{START}&state={STATE}&wt=json"
    Dim xhr As Object, totalResults As Long, numPages As Long

    Set xhr = CreateObject("MSXML2.XMLHTTP")
    apiUrl = Replace$(apiUrl, "{STATE}", state)
    s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=0"), re)

    If s = "No match" Then Exit Sub

    Set json = JsonConverter.ParseJson(s)("hits")

    totalResults = json("total")

    numPages = Application.RoundUp(totalResults / 100, 0)

    Dim results(), ws As Worksheet, headers(), i As Long
    ReDim results(1 To totalResults, 1 To 3)
    Set ws = ThisWorkbook.Worksheets("Sheet1")
    headers = Array("CRD Number", "Name", "Address")
    results = GetFirmListings(results, json("hits"))

    If numPages > 1 Then
        For i = 2 To numPages
            s = GetApiResults(xhr, Replace$(apiUrl, "{START}", "start=" & (i - 1) * 100), re)
            If s = "No match" Or InStr(s, "Exceeded limit") > 0 Then Exit For
            Set json = JsonConverter.ParseJson(s)("hits")
            results = GetIndividualListings(results, json("hits"))
        Next
    End If
    With ws
        .Cells(1, 1).Resize(1, UBound(headers) + 1) = headers
        .Cells(2, 1).Resize(UBound(results, 1), UBound(results, 2)) = results
    End With
End Sub

Public Function GetApiResults(ByVal xhr As Object, ByVal apiUrl As String, ByVal re As Object) As String
    With xhr
        .Open "GET", apiUrl, False
        .send
        GetApiResults = GetJsonString(re, .responseText)
    End With
End Function

Public Function GetIndividualListings(ByVal results As Variant, ByVal json As Object) As Variant
    Dim row As Object
      'can have numerous current employments. Alter here and below if want more info from json about the individual
    ' CRD Number, Indiv Name, FINRA registered, Disclosures, In industry since, _
    current employer firm ID, current employer firm name, current employer city, current employer state, current employer zip.
    On Error Resume Next
    For Each row In json
        r = r + 1
        results(r, 1) = row("_source")("ind_source_id")
        results(r, 2) = Replace$(Join$(Array(row("_source")("ind_firstname"), row("_source")("ind_middlename"), row("_source")("ind_lastname")), ", "), ", , ", ", ")
        results(r, 3) = row("_source")("ind_approved_finra_registration_count")
        results(r, 4) = row("_source")("ind_bc_disclosure_fl")
        results(r, 5) = row("_source")("ind_industry_cal_date")
        results(r, 6) = row("_source")("ind_current_employments")(1)("firm_id")
        results(r, 7) = row("_source")("ind_current_employments")(1)("firm_name")
        results(r, 8) = row("_source")("ind_current_employments")(1)("branch_city")
        results(r, 9) = row("_source")("ind_current_employments")(1)("branch_state")
        results(r, 10) = row("_source")("ind_current_employments")(1)("branch_zip")
    Next
    On Error GoTo 0
    GetIndividualListings = results
End Function

Public Function GetJsonString(ByVal re As Object, ByVal responseText As String) As String
    With re
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = "\((.*)\);" 'regex pattern to get json string
        If .test(responseText) Then
            GetJsonString = .Execute(responseText)(0).SubMatches(0)
        Else
            GetJsonString = "No match"
        End If
    End With
End Function