Excel VBAからcurl.exeでAPIを呼び出す方法｜終了待ち・JSON解析・安全対策

where.exe curl.exe
"C:\Tools\curl\bin\curl.exe" -q --version

url = "https://api.open-meteo.com/v1/forecast?latitude=35.68&longitude=139.76&current=temperature_2m"
output = "C:\\Example\\body.json"
write-out = "%output{C:\\Example\\status.txt}%{http_code}"

Option Explicit

Public Sub GetTokyoWeatherWithCurl()
    ' Replace with the absolute path checked with --version (curl 8.4.0+).
    Const CURL_EXE As String = "C:\Tools\curl\bin\curl.exe"
    Const API_URL As String = "https://api.open-meteo.com/v1/forecast?" & _
        "latitude=35.68&longitude=139.76&current=temperature_2m" & _
        "&temperature_unit=celsius&timezone=Asia%2FTokyo&forecast_days=1"

    Dim fso As Object, sh As Object, config As Object
    Dim root As Object, current As Object, units As Object
    Dim tempRoot As String, workDir As String, configPath As String
    Dim bodyPath As String, statusPath As String, errorPath As String
    Dim httpStatus As String, jsonText As String, stage As String
    Dim exitCode As Long, errorNumber As Long
    Dim folderCreated As Boolean, cleanupFailed As Boolean
    Dim message As String, temperature As Variant, stamp As Variant
    Dim values(1 To 2, 1 To 3) As Variant, ws As Worksheet

    On Error GoTo Failed
    stage = "Preparation"
    Set fso = CreateObject("Scripting.FileSystemObject")
    Set sh = CreateObject("WScript.Shell")
    CheckDemoPath CURL_EXE
    If Not fso.FileExists(CURL_EXE) Then Err.Raise vbObjectError + 2401

    tempRoot = fso.GetSpecialFolder(2).Path
    ' If this path is unsupported, use an existing private local ASCII folder.
    CheckDemoPath tempRoot
    workDir = fso.BuildPath(tempRoot, fso.GetTempName)
    fso.CreateFolder workDir
    folderCreated = True
    configPath = fso.BuildPath(workDir, "request.cfg")
    bodyPath = fso.BuildPath(workDir, "body.json")
    statusPath = fso.BuildPath(workDir, "status.txt")
    errorPath = fso.BuildPath(workDir, "curl-error.txt")

    ' All config text is ASCII. Do not add credentials or user-supplied options.
    Set config = fso.CreateTextFile(configPath, False, False)
    config.WriteLine "url = " & ConfigString(API_URL)
    config.WriteLine "proto = " & ConfigString("=https")
    config.WriteLine "silent"
    config.WriteLine "show-error"
    config.WriteLine "connect-timeout = 5"
    config.WriteLine "max-time = 20"
    config.WriteLine "max-filesize = 1048576"
    config.WriteLine "header = " & ConfigString("Accept: application/json")
    config.WriteLine "output = " & ConfigString(bodyPath)
    config.WriteLine "stderr = " & ConfigString(errorPath)
    config.WriteLine "write-out = " & _
        ConfigString("%output{" & statusPath & "}%{http_code}")
    config.Close
    Set config = Nothing

    stage = "curl execution"
    ' No cmd.exe, no redirection, and no fixed-duration guess at completion.
    ' -q is first so an existing default curl config is not loaded.
    exitCode = sh.Run(CommandPath(CURL_EXE) & " -q --config " & _
        CommandPath(configPath), 0, True)
    If exitCode <> 0 Then
        message = "curl failed. Exit code: " & CStr(exitCode)
        GoTo CleanUp
    End If

    stage = "HTTP status"
    ' A write-out file failure may NOT change curl's exit code.
    If Not fso.FileExists(statusPath) Then Err.Raise vbObjectError + 2402
    If fso.GetFile(statusPath).Size <> 3 Then Err.Raise vbObjectError + 2403
    httpStatus = ReadUtf8File(statusPath)
    If Not httpStatus Like "[1-5]##" Then Err.Raise vbObjectError + 2404
    If httpStatus <> "200" Then
        message = "API did not return HTTP 200. HTTP status: " & httpStatus
        GoTo CleanUp
    End If

    stage = "JSON parsing and schema"
    If Not fso.FileExists(bodyPath) Then Err.Raise vbObjectError + 2405
    If fso.GetFile(bodyPath).Size = 0 Then Err.Raise vbObjectError + 2406
    If fso.GetFile(bodyPath).Size > 1048576 Then Err.Raise vbObjectError + 2407
    jsonText = ReadUtf8File(bodyPath)
    Set root = JsonConverter.ParseJson(jsonText)
    If TypeName(root) <> "Dictionary" Then Err.Raise vbObjectError + 2408
    Set current = RequiredDictionary(root, "current")
    Set units = RequiredDictionary(root, "current_units")
    If Not current.Exists("time") Then Err.Raise vbObjectError + 2409
    If Not current.Exists("temperature_2m") Then Err.Raise vbObjectError + 2410
    If Not units.Exists("temperature_2m") Then Err.Raise vbObjectError + 2411
    If VarType(units("temperature_2m")) <> vbString Then Err.Raise vbObjectError + 2412
    If units("temperature_2m") <> (ChrW(176) & "C") Then Err.Raise vbObjectError + 2413
    stamp = current("time")
    If VarType(stamp) <> vbString Then Err.Raise vbObjectError + 2414
    If Not stamp Like "####-##-##T##:##" Then Err.Raise vbObjectError + 2415
    temperature = current("temperature_2m")
    Select Case VarType(temperature)
        Case vbByte, vbInteger, vbLong, vbSingle, vbDouble, vbCurrency, vbDecimal
            ' A JSON number, not null, Boolean, or a numeric-looking string.
        Case Else
            Err.Raise vbObjectError + 2416
    End Select

    stage = "Worksheet output"
    values(1, 1) = "Time (Asia/Tokyo)"
    values(1, 2) = "Temperature (" & ChrW(176) & "C)"
    values(1, 3) = "Source"
    values(2, 1) = stamp
    values(2, 2) = temperature
    values(2, 3) = "Open-Meteo.com (CC BY 4.0)"
    Set ws = ThisWorkbook.Worksheets.Add(After:= _
        ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
    ws.Range("A1:C2").NumberFormat = "@"
    ws.Range("B2").NumberFormat = "0.0"
    ws.Range("A1:C2").Value2 = values
    ws.Range("C3").Value2 = "https://open-meteo.com/"
    ws.Range("C4").Value2 = "https://creativecommons.org/licenses/by/4.0/"
    ws.Columns("A:C").AutoFit
    message = "Completed. A new worksheet contains the validated result."
    GoTo CleanUp

Failed:
    errorNumber = Err.Number
    ' Do not display raw response data, full commands, or credentials.
    message = "Stopped at: " & stage & ". VBA error: " & CStr(errorNumber)

CleanUp:
    On Error Resume Next
    If Not config Is Nothing Then config.Close
    If folderCreated Then
        Err.Clear
        fso.DeleteFolder workDir, True
        cleanupFailed = (Err.Number <> 0)
    End If
    On Error GoTo 0
    If cleanupFailed Then message = message & vbCrLf & _
        "Temporary files remain. Remove this run's folder: " & workDir
    MsgBox message, vbInformation
End Sub

Private Function RequiredDictionary(ByVal parent As Object, ByVal key As String) As Object
    If Not parent.Exists(key) Then Err.Raise vbObjectError + 2420
    If Not IsObject(parent(key)) Then Err.Raise vbObjectError + 2421
    If TypeName(parent(key)) <> "Dictionary" Then Err.Raise vbObjectError + 2422
    Set RequiredDictionary = parent(key)
End Function

Private Sub CheckDemoPath(ByVal path As String)
    Dim i As Long, n As Long, c As String
    ' Deliberately narrow demo: local drive, ASCII, no expansion/delimiter chars.
    If Len(path) < 4 Then Err.Raise vbObjectError + 2430
    If Not Left$(path, 3) Like "[A-Za-z]:\" Then Err.Raise vbObjectError + 2431
    If Right$(path, 1) = "\" Then Err.Raise vbObjectError + 2432
    For i = 1 To Len(path)
        c = Mid$(path, i, 1)
        n = AscW(c)
        If n < 32 Or n > 126 Then Err.Raise vbObjectError + 2433
        If InStr(1, """%{}", c, vbBinaryCompare) > 0 Then _
            Err.Raise vbObjectError + 2434
    Next i
End Sub

Private Function CommandPath(ByVal path As String) As String
    CheckDemoPath path
    CommandPath = Chr$(34) & path & Chr$(34)
End Function

Private Function ConfigString(ByVal value As String) As String
    ' curl config-file quoting is different from VBA/Windows command quoting.
    value = Replace(value, "\", "\\")
    value = Replace(value, Chr$(34), "\" & Chr$(34))
    ConfigString = Chr$(34) & value & Chr$(34)
End Function

Private Function ReadUtf8File(ByVal path As String) As String
    Dim stream As Object, savedNumber As Long
    On Error GoTo Failed
    Set stream = CreateObject("ADODB.Stream")
    stream.Type = 2  ' adTypeText
    stream.Charset = "utf-8"
    stream.Open
    stream.LoadFromFile path
    ReadUtf8File = stream.ReadText(-1)
    stream.Close
    Exit Function
Failed:
    savedNumber = Err.Number
    On Error Resume Next
    If Not stream Is Nothing Then stream.Close
    On Error GoTo 0
    Err.Raise savedNumber
End Function