【VBA】Web APIを使って時間別天気予報を取得する（気象庁API）

Option Explicit

Public Sub 気象庁天気取得()


  '気象庁から情報を取得
    Call ForecastData
     
End Sub

Private Sub ForecastData()

 '@yamato1413さんのサイトからforcastcode取得
 '{"forecastcode":"130000","prefname":"東京都",}
    
   Const forecastcode As String = "130000"
   
   Dim http As MSXML2.XMLHTTP60
   Set http = New MSXML2.XMLHTTP60
   Dim WeatherDateTime As String
   Dim RainDateTime As String
   Dim i As Long
   Dim j As Long

   
    With http
        Call .Open("GET", "https://www.jma.go.jp/bosai/forecast/data/forecast/" & forecastcode & ".json")
        Call .send
        
        Do
            If .readyState = 4 Then Exit Do
            DoEvents
        Loop
        
        'JSONを一行で出力
        ThisWorkbook.Worksheets(1).Range("A1").Value = .responseText
        
        'JSONパース
        Dim jsonObj As Object
        Set jsonObj = JsonConverter.ParseJson(.responseText)
          
        '東京地方の天気情報取得
        '天気
        For i = 1 To jsonObj(1)("timeSeries")(1)("areas")(1)("weathers").Count
            WeatherDateTime = Left(jsonObj(1)("timeSeries")(1)("timeDefines")(i), 19)
            Debug.Print WeatherDateTime & vbCrLf & jsonObj(1)("timeSeries")(1)("areas")(1)("weathers")(i)
        Next i
        
        '降水確率
        For j = 1 To jsonObj(1)("timeSeries")(2)("areas")(1)("pops").Count
            RainDateTime = Left(jsonObj(1)("timeSeries")(2)("timeDefines")(i), 19) & "から6時間ごとの降水確率"
            Debug.Print RainDateTime & " " & jsonObj(1)("timeSeries")(2)("areas")(1)("pops")(i) & "％"
        Next j
        

    End With
End Sub

[
	{
		"publishingOffice": "気象庁",
		"reportDatetime": "2022-04-16T05:00:00+09:00",
		"timeSeries": [
			{
				"timeDefines": [
					"2022-04-16T05:00:00+09:00",
					"2022-04-17T00:00:00+09:00"
				],
				"areas": [
					{
						"area": {
							"name": "東京地方",
							"code": "130010"
						},
						"weatherCodes": [
							"211",
							"111"
						],
						"weathers": [
							"くもり　昼過ぎ　から　晴れ　所により　朝　まで　雨",
							"晴れ　昼過ぎ　から　くもり　所により　夜　雨"
						],
						"winds": [
							"北の風　２３区西部　では　はじめ　北の風　やや強く",
							"北の風　後　南の風"
						],
						"waves": [
							"１メートル　後　０．５メートル",
							"０．５メートル"
						]
					},
					{
						"area": {
							"name": "伊豆諸島北部",
							"code": "130020"
						},
						"weatherCodes": [
							"200",
							"200"
						],
						"weathers": [
							"くもり　所により　昼前　まで　雨",
							"くもり　所により　夜　雨"
						],
						"winds": [
							"北の風　強く　後　北東の風　やや強く",
							"北東の風　やや強く　後　東の風"
						],
						"waves": [
							"４メートル　うねり　を伴う　ただし　新島　では　５メートル　後　４メートル　うねり　を伴う",
							"３メートル　後　２メートル　うねり　を伴う"
						]
					},
					{
						"area": {
							"name": "伊豆諸島南部",
							"code": "130030"
						},
						"weatherCodes": [
							"200",
							"201"
						],
						"weathers": [
							"くもり　所により　夜のはじめ頃　まで　雨",
							"くもり　時々　晴れ"
						],
						"winds": [
							"北の風　強く　後　北東の風　やや強く",
							"北東の風　やや強く　後　東の風"
						],
						"waves": [
							"６メートル　後　５メートル　うねり　を伴う　ただし　三宅島　では　５メートル　うねり　を伴う",
							"４メートル　後　２．５メートル　うねり　を伴う"
						]
					},
					{
						"area": {
							"name": "小笠原諸島",
							"code": "130040"
						},
						"weatherCodes": [
							"201",
							"201"
						],
						"weathers": [
							"くもり　時々　晴れ",
							"くもり　時々　晴れ"
						],
						"winds": [
							"西の風　強く　後　北の風",
							"北東の風　後　東の風"
						],
						"waves": [
							"６メートル　後　３メートル　うねり　を伴う",
							"３メートル　後　２．５メートル　うねり　を伴う"
						]
					}
				]
			},
			{
				"timeDefines": [
					"2022-04-16T06:00:00+09:00",
					"2022-04-16T12:00:00+09:00",
					"2022-04-16T18:00:00+09:00",
					"2022-04-17T00:00:00+09:00",
					"2022-04-17T06:00:00+09:00",
					"2022-04-17T12:00:00+09:00",
					"2022-04-17T18:00:00+09:00"
				],
				"areas": [
					{
						"area": {
							"name": "東京地方",
							"code": "130010"
						},
						"pops": [
							"20",
							"10",
							"10",
							"0",
							"0",
							"10",
							"20"

Private Function json_Encode(ByVal json_Text As Variant) As String
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
       Case 0 To 31, 127 To 65535
            ' Non-ascii characters -> convert to 4-digit hex
            json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
        End Select　

Private Function json_Encode(ByVal json_Text As Variant) As String
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～～
       Case 0 To 31, 127 'To 65535を消去する
            ' Non-ascii characters -> convert to 4-digit hex
            json_Char = "\u" & VBA.Right$("0000" & VBA.Hex$(json_AscCode), 4)
        End Select　

 '天気
        For i = 1 To jsonObj(1)("timeSeries")(1)("areas")(1)("weathers").Count
            WeatherDateTime = Left(jsonObj(1)("timeSeries")(1)("timeDefines")(i), 19)
            Debug.Print WeatherDateTime & vbCrLf & jsonObj(1)("timeSeries")(1)("areas")(1)("weathers")(i)
        Next i

  '降水確率
        For j = 1 To jsonObj(1)("timeSeries")(2)("areas")(1)("pops").Count
            RainDateTime = Left(jsonObj(1)("timeSeries")(2)("timeDefines")(i), 19) & "から6時間ごとの降水確率"
            Debug.Print RainDateTime & " " & jsonObj(1)("timeSeries")(2)("areas")(1)("pops")(i) & "％"
        Next j

2022-04-16T17:00:00
晴れ　夜のはじめ頃　くもり
2022-04-17T00:00:00
晴れ　後　くもり　夜　雨
2022-04-18T00:00:00
くもり
2022-04-17T12:00:00から6時間ごとの降水確率 30％
2022-04-17T12:00:00から6時間ごとの降水確率 30％
2022-04-17T12:00:00から6時間ごとの降水確率 30％
2022-04-17T12:00:00から6時間ごとの降水確率 30％
2022-04-17T12:00:00から6時間ごとの降水確率 30％