最新の雨雲レーダから画像データを取得する
1.概要
国土交通省が情報提供しているリアルタイムレーダー観測雨量の地域ブロック別に分割されている観測画像を一括して取得し、一覧画面として
表示します。地域ブロックは、全国、沖縄地方、九州地方、四国地方、中国地方、近畿地方、中部地方、北陸地方、関東地方、東北地方、北海道地方
で全国を含めて計11の地方ブロックとなっています。データは国土交通省の雨雲レーダーの最新更新時の画像データを取得・表示します。
2.レーダー観測雨量の取得 ※【注意】河川の防災情報がリニューアルされたため、情報の取得ができませんので、提供を中止します。 利用は不可です。 レーダー観測雨量の取得は、Excel VBAにて作成したマクロで取得・表示します。観測データは、画像ファイルとなっていて イメージ情報として、地域エリアコードと時と分を組み合わせたものがURLのパラメータとして渡されます。 取得画像形式は、gif形式となっています。
Excel VBAマクロで作成した、国土交通省_レーダ観測雨量取得.xlsmを起動すると、自動で取得して一覧表示させています。 再度、時間をおいて実行する場合は、レーダー観測雨量ボタンをクリックします。.また、手動で画面のクリア(消去)する場合は、 消去ボタンをクリックします。取得時には、取得前に消去させていますので、手動消去は必要ありません。 3.ソースコード 下記のリストは、国土交通省_レーダ観測雨量取得.xlsmのソースコードです。 ALT+F11でVBE(エディタ)を開いて、ソースコードを確認して下さい。
ThisWorkbookは、起動時の処理のため、Workbook_Open()で Worksheets("MAIN")のGetUryouを呼び出して 自動的にレーダー雨量観測画像データを取得しています。 次に標準モジュール : APIModは、Sheet1(MAIN)で利用するWindows APIを3つ定義しています。 Sleep関数は、待ち時間を指定するものです。
ShowWindow関数は、ウィンドウを最大化するか最小化するかの動作をさせるためのものです。
URLDownloadToFile関数は指定URLのファイルを、指定パスにダウンロードするためのものです。 Sheet1(MAIN)がメインプログラムです。
Sub xmp_Click()は、XRAINバナー画像をクリックした時のリンク処理です。
Sub GetUryou()が実際の取得処理部分です。
レーダー観測雨量の観測雨量表示(合計11エリアの最新画像を連続取得)をするためのエリアのURLを配列に格納して、 観測画像のURLへ渡すために年月日の合成パラメータ作成を作成しています。 GetimgDownルーチンでAPIのURLDownloadToFilにて画像をダウンロードしています。 これらの処理をループで回して処理し、取得した観測画像をシート上の指定位置に配置していきます。 新規に画像を取得する前に、以前の取得済みの画像を削除するためにpicDelete()ルーチンをコールして消去処理します。 picDelete()ルーチンですが、最初の1回目の処理時に何故か沖縄地方の画像だけが消去できずに残ってしまう現象が でています。いろいろ試行しているのですが、現時点で解消できていません。手動で削除して下さい。2回目以降の実行では正常に処理されています。 どなたか解決方法をご存じでしたら、コメント欄にアドバイス頂けたら、ありがたいです。
実行前に参照設定を確認して下さい。エディタのツール → 参照設定で下記の3つのライブラリにチェックがされていればOKです。 チェックされていなければ、チェックして下さい。
ダウンロード
2.レーダー観測雨量の取得 ※【注意】河川の防災情報がリニューアルされたため、情報の取得ができませんので、提供を中止します。 利用は不可です。 レーダー観測雨量の取得は、Excel VBAにて作成したマクロで取得・表示します。観測データは、画像ファイルとなっていて イメージ情報として、地域エリアコードと時と分を組み合わせたものがURLのパラメータとして渡されます。 取得画像形式は、gif形式となっています。
Excel VBAマクロで作成した、国土交通省_レーダ観測雨量取得.xlsmを起動すると、自動で取得して一覧表示させています。 再度、時間をおいて実行する場合は、レーダー観測雨量ボタンをクリックします。.また、手動で画面のクリア(消去)する場合は、 消去ボタンをクリックします。取得時には、取得前に消去させていますので、手動消去は必要ありません。 3.ソースコード 下記のリストは、国土交通省_レーダ観測雨量取得.xlsmのソースコードです。 ALT+F11でVBE(エディタ)を開いて、ソースコードを確認して下さい。
ThisWorkbookは、起動時の処理のため、Workbook_Open()で Worksheets("MAIN")のGetUryouを呼び出して 自動的にレーダー雨量観測画像データを取得しています。 次に標準モジュール : APIModは、Sheet1(MAIN)で利用するWindows APIを3つ定義しています。 Sleep関数は、待ち時間を指定するものです。
ShowWindow関数は、ウィンドウを最大化するか最小化するかの動作をさせるためのものです。
URLDownloadToFile関数は指定URLのファイルを、指定パスにダウンロードするためのものです。 Sheet1(MAIN)がメインプログラムです。
Sub xmp_Click()は、XRAINバナー画像をクリックした時のリンク処理です。
Sub GetUryou()が実際の取得処理部分です。
レーダー観測雨量の観測雨量表示(合計11エリアの最新画像を連続取得)をするためのエリアのURLを配列に格納して、 観測画像のURLへ渡すために年月日の合成パラメータ作成を作成しています。 GetimgDownルーチンでAPIのURLDownloadToFilにて画像をダウンロードしています。 これらの処理をループで回して処理し、取得した観測画像をシート上の指定位置に配置していきます。 新規に画像を取得する前に、以前の取得済みの画像を削除するためにpicDelete()ルーチンをコールして消去処理します。 picDelete()ルーチンですが、最初の1回目の処理時に何故か沖縄地方の画像だけが消去できずに残ってしまう現象が でています。いろいろ試行しているのですが、現時点で解消できていません。手動で削除して下さい。2回目以降の実行では正常に処理されています。 どなたか解決方法をご存じでしたら、コメント欄にアドバイス頂けたら、ありがたいです。
実行前に参照設定を確認して下さい。エディタのツール → 参照設定で下記の3つのライブラリにチェックがされていればOKです。 チェックされていなければ、チェックして下さい。
-
・Visual Basic For Applications
・Microsoft Excel 16.0 Object Library
・Microsoft Forms 2.0 Object Library
'***** ブックを開いた時の初期設定処理 ***** Private Sub Workbook_Open() Sheets("MAIN").Select Worksheets("MAIN").Activate Worksheets("MAIN").Range("H1") = "データ取得中" Worksheets("MAIN").IENavi.Enabled = False Worksheets("MAIN").DataCLR.Enabled = False Call Worksheets("MAIN").GetUryou End Sub
'***** 【重要】32bit版の場合は、APIの宣言部中の PtrSafe を削除して下さい。(Excel2010以降は、このままでも大丈夫のはずです) ***** ' sleep API宣言 Public Declare PtrSafe Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long) ' ShowWindow API宣言 Public Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hwindow As Long, ByVal cmdshow As Long) As Long ' URLDownloadToFile API宣言 Public Declare PtrSafe Function URLDownloadToFile Lib "urlmon" _ Alias "URLDownloadToFileA" (ByVal pCaller As Long, _ ByVal szURL As String, ByVal szFileName As String, _ ByVal dwReserved As Long, ByVal lpfnCB As Long) As Long
'************************************************************************************* '* 国土交通省_レーダ観測雨量取得.xlsm Ver1.3 '* ●国土交通省 - 最新の雨雲レーダからの画像データ取得 '* '* 国土交通省HP : https://www.river.go.jp/ '* '* ※データ消去しても初回に取得画像が時々一部残る現象が発生することがあります。 '* 対象の画像を選択して削除願います。2回目以降はOKです。(原因不明) '* '* '* ●参照設定 (ツール → 参照設定で下記のライブラリの参照を確認のこと) '* Visual Basic For Applications '* Microsoft Excel 16.0 Object Library '* Microsoft Forms 2.0 Object Library '* '************************************************************************************* Option Explicit '***** 国土交通省XバンドMPレーダ雨量情報 ***** Private Sub xmp_Click() Dim URL As String Dim objIE As Object Dim ret As Integer Set objIE = CreateObject("InternetExplorer.Application") objIE.Visible = False '***** 初期起動ページ表示 ***** '***** 地域選択画面 ***** URL = "http://www.river.go.jp/x/xmn0107010.php" objIE.Navigate URL Do While objIE.ReadyState <> 4 Do While objIE.Busy = True DoEvents Loop Loop '***** 最小化 = 2 最大化 =3 ***** ret = ShowWindow(objIE.Hwnd, 3) objIE.Visible = True '***** IE object解放 ***** 'objIE.Quit Set objIE = Nothing End Sub '***** データ消去 ***** Private Sub DataCLR_Click() '***** シートにある画像を削除 ***** Call picDelete End Sub '***** 起動開始 ***** Private Sub IENavi_Click() Range("H1") = "データ取得中" IENavi.Enabled = False DataCLR.Enabled = False Call picDelete Call GetUryou End Sub '***** 国土交通省 - レーダ観測雨量表示(合計11エリアの最新画像を連続取得) ***** Public Sub GetUryou() Dim URL As String Dim sDate As String Dim sHH, sMI As String Dim sTime As String Dim UriyouArea(10) As String Dim L, i As Integer Dim TempMsg As Variant Dim strPicFileName As String Dim getdateName As String Dim iCell As String Dim iSheet As String Dim cpImgFname As String Dim GetDispName As String Dim CellPos As Variant CellPos = Array("B5", "D5", "F5", "H5", "B8", "D8", "F8", "H8", "B11", "D11", "F11") '***** エリア ***** UriyouArea(0) = "https://www.river.go.jp/kawabou/imageOut/31/80/" '全国 UriyouArea(1) = "https://www.river.go.jp/kawabou/imageOut/31/90/" '沖縄 UriyouArea(2) = "https://www.river.go.jp/kawabou/imageOut/31/89/" '九州 UriyouArea(3) = "https://www.river.go.jp/kawabou/imageOut/31/88/" '四国 UriyouArea(4) = "https://www.river.go.jp/kawabou/imageOut/31/87/" '中国 UriyouArea(5) = "https://www.river.go.jp/kawabou/imageOut/31/86/" '近畿 UriyouArea(6) = "https://www.river.go.jp/kawabou/imageOut/31/85/" '中部 UriyouArea(7) = "https://www.river.go.jp/kawabou/imageOut/31/84/" '北陸 UriyouArea(8) = "https://www.river.go.jp/kawabou/imageOut/31/83/" '関東 UriyouArea(9) = "https://www.river.go.jp/kawabou/imageOut/31/82/" '東北 UriyouArea(10) = "https://www.river.go.jp/kawabou/imageOut/31/81/" '北海道 Dim DispPos As Variant DispPos = Array("B4", "D4", "F4", "H4", "B7", "D7", "F7", "H7", "B10", "D10", "F10") Dim DispName As Variant DispName = Array("全国", "沖縄地方", "九州地方", "四国地方", "中国地方", "近畿地方" _ , "中部地方", "北陸地方", "関東地方", "東北地方", "北海道地方") On Error Resume Next Call picDelete ' 年月日の合成パラメータ作成 sDate = Year(Date) & Format(Month(Date), "00") & Format(Day(Date), "00") ' 時分の合成パラメータ作成 sHH = Format(Hour(Time), "00") sMI = Trim(Minute(Time)) L = Len(Trim(Minute(Time))) '************************************************** '* ※データの時間遅れがあるので時間調整をする '************************************************** If L = 1 Then If Val(Minute(Time)) < 5 Then sMI = Format(Val(sHH - 1), "00") & "50" Else sMI = Format(Val(sHH - 1), "00") & "55" End If End If If L = 2 Then If Val(Mid(sMI, 2, 1)) > 5 Then sMI = sHH & Val(Mid(sMI, 1, 1) - 1) & "5" Else sMI = sHH & Val(Mid(sMI, 1, 1) - 1) & "0" End If End If '***** 取得日時表示 ***** GetDispName = Mid(sDate, 1, 4) & "年" & Mid(sDate, 5, 2) & "月" & Mid(sDate, 7, 2) & "日" _ & " " & Mid(sMI, 1, 2) & ":" & Mid(sMI, 3, 2) & " 現在" Range("B2").Value = GetDispName iSheet = "MAIN" '▼▼▼▼▼ ここから繰り返し処理開始 ▼▼▼▼▼ '***** 取得(ダウンロード)した画像のファイル名とする ***** getdateName = "Uriyou" '***** 自動巡回開始 ***** For i = 0 To 10 ' URLパラメータ合成 URL = UriyouArea(i) & sDate & "/" & sMI & "00.gif" Range(DispPos(i)).Value = DispName(i) Call GetimgDown(URL, strPicFileName, getdateName, i) cpImgFname = strPicFileName iCell = CellPos(i) '***** 画像のサムネイル処理開始 ***** Call MovPicture(cpImgFname, iSheet, iCell) Kill cpImgFname Next i Application.StatusBar = False Range("H1") = "" Range("A1").Select IENavi.Enabled = True DataCLR.Enabled = True End Sub '***** 画像のダウンロード ***** Private Sub GetimgDown(strURL As String, ByRef strFNAME As String, ImageName As String, nflag As Integer) Dim strWORK As String Dim OutImgName As String Dim returnValue strFNAME = ThisWorkbook.Path & "¥" & nflag & "_" & ImageName & ".gif" 'URLDownloadToFile API をコールする returnValue = URLDownloadToFile(0, strURL, strFNAME, 0, 0) If returnValue <> 0 Then MsgBox "レーダ雨量画像を取得できません。" End If End Sub '***** 画像のサムネイル処理 ***** Sub MovPicture(cpImgFname As String, iSheet As String, iCell As String) Dim MovCell As Range Dim MovLeft As Double Dim MovTop As Double Dim MovHeight As Double Dim MovWidth As Double Set MovCell = Range(iCell) With MovCell MovLeft = .Left + 1 MovTop = .Top + 1 MovHeight = .Cells(.Count).Offset(1).Top - .Top - 1 MovWidth = .Cells(.Count).Offset(, 1).Left - .Left - 1 End With Sheets(iSheet).Pictures.Insert (cpImgFname) With Sheets(iSheet).Pictures(Sheets(iSheet).Pictures.Count).ShapeRange .LockAspectRatio = msoFalse .Parent.Visible = msoTrue .Left = MovLeft .Top = MovTop .Height = MovHeight .Width = MovWidth End With End Sub Sub picDelete() Dim myPc As Object '***** 前回取得してシート上にある画像の削除 (OLEObjectの選択回避) ***** For Each myPc In ActiveSheet.Pictures If TypeName(myPc) <> "OLEObject" Then myPc.Select False Selection.Delete End If Next End Sub '***** ブラウザナビゲート ***** Private Sub objIE_BeforeNavigate2(ByVal pDisp As Object, URL As Variant, Flags As Variant, TargetFrameName As Variant, PostData As Variant, Headers As Variant, Cancel As Boolean) End Sub '***** ブラウザドキュメント表示 ***** Private Sub objIE_DocumentComplete(ByVal pDisp As Object, URL As Variant) dsp_flg = True Application.StatusBar = objIE.Document.Title ' Titleを取得 End Sub4.ダウンロード 提供するソースコードのライセンスは、CC0 (クレジット表示不要、改変可、商用可) とします。自由に利用して頂いてかまいません。 国土交通省_レーダ観測雨量取得.xlsmは下記からダウンロードして下さい。何の役に立てるかどうかわかりませんが、参考として頂けたらと思います。
ダウンロード
コメント
コメントを投稿