最新の雨雲レーダから画像データを取得する

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です。 チェックされていなければ、チェックして下さい。
    ・Visual Basic For Applications
    ・Microsoft Excel 16.0 Object Library
    ・Microsoft Forms 2.0 Object Library
もうひとつ大切なことを書き忘れていました。標準モジュール : APIModのAPI定義は、64bit版のExcelに対応するために、関数定義に PtrSafeを入れています。32bit版のExcelをご利用の場合は、PtrSafe部分を消して 下さい。

'***** ブックを開いた時の初期設定処理 *****
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 Sub

4.ダウンロード

提供するソースコードのライセンスは、CC0 (クレジット表示不要、改変可、商用可) とします。自由に利用して頂いてかまいません。 国土交通省_レーダ観測雨量取得.xlsmは下記からダウンロードして下さい。何の役に立てるかどうかわかりませんが、参考として頂けたらと思います。

ダウンロード

コメント

このブログの人気の投稿

Excelアドインで日本語形態素解析

階層構造JSONファイルの作成

HSPでコマンドプロンプトを制御する

TOP