kiến thức [Excel VBA] Sử dụng API để lấy dữ liệu từ nhà cung cấp dịch vụ nhất định

    <current>
    <city id="3163858" name="Zocca">
    <coord lon="10.99" lat="44.34"/>
    <country>IT</country>
    <timezone>7200</timezone>
    <sun rise="2022-08-30T04:36:27" set="2022-08-30T17:57:28"/>
    </city>
    <temperature value="298.48" min="297.56" max="300.05" unit="kelvin"/>
    <feels_like value="298.74" unit="kelvin"/>
    <humidity value="64" unit="%"/>
    <pressure value="1015" unit="hPa"/>
    <wind>
    <speed value="0.62" unit="m/s" name="Calm"/>
    <gusts value="1.18"/>
    <direction value="349" code="N" name="North"/>
    </wind>
    <clouds value="100" name="overcast clouds"/>
    <visibility value="10000"/>
    <precipitation value="3.37" mode="rain" unit="1h"/>
    <weather number="501" value="moderate rain" icon="10d"/>
    <lastupdate value="2022-08-30T14:45:57"/>
    </current>

Option Explicit

Public Function CurrentWeather(Location As Variant, Optional Degree As Variant = "c") As Variant
    Dim objXMLHTTP As MSXML2.XMLHTTP60
    Dim objXMLDoc As MSXML2.DOMDocument60
    Dim objXMLNodeList As MSXML2.IXMLDOMNodeList
    Dim objXMLNode As MSXML2.IXMLDOMNode
    Dim strTempValue As String, strWeatherCondition As String
    Dim strURL As String, strResult As String
    Dim strAPI As String
    Dim strDegree As String
    strAPI = "9d06ba06acac21af5c90d5aa7ea59ddf"
    Select Case Degree
        Case "c"
            strURL = "https://api.openweathermap.org/data/2.5/weather?q=" & Location & "&appid=" & strAPI & "&lang=vi&units=metric&mode=xml"
            strDegree = " C, "
        Case "f"
            strURL = "https://api.openweathermap.org/data/2.5/weather?q=" & Location & "&appid=" & strAPI & "&lang=vi&units=imperial&mode=xml"
            strDegree = " F, "
        Case Else
            strURL = "https://api.openweathermap.org/data/2.5/weather?q=" & Location & "&appid=" & strAPI & "&lang=vi&units=standard&mode=xml"
            strDegree = " C, "
    End Select
    Set objXMLHTTP = New MSXML2.XMLHTTP60
    With objXMLHTTP
        .Open "GET", strURL, False
        .Send
        If .Status = 200 Then
            Set objXMLDoc = New MSXML2.DOMDocument60
            objXMLDoc.LoadXML .ResponseText
            Set objXMLNodeList = objXMLDoc.SelectNodes("current")
            For Each objXMLNode In objXMLNodeList
                strTempValue = objXMLNode.SelectSingleNode("temperature").Attributes.getNamedItem("value").Text
                strResult = strTempValue & strDegree
                strWeatherCondition = objXMLNode.SelectSingleNode("weather").Attributes.getNamedItem("value").Text
                strResult = strResult & strWeatherCondition
            Next
        End If
    End With
    CurrentWeather = strResult
    Set objXMLHTTP = Nothing
    Set objXMLNodeList = Nothing
    Set objXMLNode = Nothing
    Set objXMLDoc = Nothing
End Function

Option Explicit

Private Sub GetGoogleSheetsRangeValues()
    Dim objWinHttpRequest As WinHttp.WinHttpRequest
    Dim objDict As Scripting.Dictionary
    Dim i As Integer, j As Integer
    Set objWinHttpRequest = New WinHttp.WinHttpRequest
    With objWinHttpRequest
        .Open "GET", "https://sheets.googleapis.com/v4/spreadsheets/1C0pYTtba4H7rg8MKLMVdYt9k6F3kz1MNZX6dw3kUrXo/values/Sheet1!A1:E5?key=API_KEY"
        .Send
        If .Status = 200 Then
            ' VBA-JSON: https://github.com/VBA-tools/VBA-JSON
            Set objDict = JsonConverter.ParseJson(.ResponseText)
            For i = 1 To objDict.Item("values").Count
                For j = 1 To objDict.Item("values")(i).Count
                    Debug.Print objDict.Item("values")(i)(j)
                Next
            Next
        End If
    End With
    Set objWinHttpRequest = Nothing
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

Option Explicit

Public Sub LoginToFShare()
    Dim objWinHTTP As WinHttp.WinHttpRequest
    Dim strRequestBody As String
    strRequestBody = "{" & _
                Quote("user_email") & ": " & Quote("Account_Name") & ", " & _
                Quote("password") & ": " & Quote("Account_Password") & ", " & _
                Quote("app_key") & ": " & Quote("app_key") & " " & _
                "}"
    Set objWinHTTP = New WinHttp.WinHttpRequest
    With objWinHTTP
        .Open "POST", "https://api.fshare.vn/api/user/login"
        .SetRequestHeader "User-Agent", "User_Agent"
        .SetRequestHeader "Accept", "application/json"
        .Send strRequestBody
        If .Status = 200 Then
            Debug.Print .ResponseText
        Else: Debug.Print .ResponseText
        End If
    End With
    Set objWinHTTP = Nothing
End Sub

Private Function Quote(Text As String) As String
    Quote = Chr(34) & Text & Chr(34)
End Function

{
  "code": 200,
  "msg": "Login successfully!",
  "token": "884fde3ee0a7fa60998",
  "session_id": "ksuku8vdfqd"
}

Option Explicit

Sub ParseJson()
    Const strURL As String = "https://masboard.masvn.com/api/v1/market/symbolHistory?symbol=A32&from=20230124&to=20230224&fetchCount=100"
    Dim objWinHttp As Object
    Set objWinHttp = CreateObject("WinHttp.WinHttpRequest.5.1")
    With objWinHttp
        .Open "GET", strURL, True
        .SetRequestHeader "Accept", "application/json"
        .SetRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/110.0.0.0 Safari/537.36 Edg/110.0.1587.50"
        .Send
        .WaitForResponse
        If .Status = 200 Then
            Dim objJson As New Collection
            Set objJson = JsonConverter.ParseJson(.ResponseText)
            Dim i As Long
            If objJson.Count > 0 Then
                For i = 1 To objJson.Count
                    If IsNull(objJson.Item(i)("vo")) Then
                        Debug.Print vbNullString
                    Else: Debug.Print objJson.Item(i)("vo")
                    End If
                Next
            End If
            Else: MsgBox "An error occurred"
        End If
    End With
End Sub