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

-
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アドインで日本語形態素解析

-
イメージ
1.概要 日本語形態素解析とは、文法的な情報の注記の無い自然言語のテキストデータ（文）から、対象言語の文法や、辞書と呼ばれる単語の品詞等の情報に基づき、 形態素（Morpheme, おおまかにいえば、言語で意味を持つ最小単位）の列に分割し、それぞれの形態素の品詞等を判別する作業です。（出典:Wikipedia） 形態素解析エンジンとしては、Mecabが有名です。筆者もPythonにインストールして、テキストマイニングに利用しています。しかし、会社などで利用したい 場合は、このような環境を個人的な利用目的で構築するにしても、セキュリティ上の問題などでIT管理者などから利用許可が下りない場合があります。 今回は、普段から利用しているExcelのアドインでテキストマイニングをして見たいと思います。特別なサーバーなどへのインストールなしで、 個人PCにアドインのインストール許可さえもらえれば誰でも簡単にテキストマイニング(ワードクラウド)分析をすることができます。 2.利用方法 (1)Excelのアドインである「E2D3」を追加します。「挿入」→「アドインを入手」をクリックし      「データ分析」を選択して、「E2D3」を探します。見つかったら、「追加」をクリックしま      す。これで、「E2D3」が利用できるようになります。 (2)分析するデータ(テキスト文書)を準備します。 (3)下記サイトの日本語形態素解析サービス(無料ツール)を利用して、文書を解析し品詞毎に分解、      統計データとして出力します。 日本語形態素解析サービス(無料ツール) URL : https://opendata-web.site/tool/parse/ ※ブックマーク等に登録しておくと良いでしょう。 (4)分析するデータ(テキスト文書)をテキストボックスに貼付け、解析ボタンをクリックします。 (5)解析結果が日本語形態素と統計の2種類画面出力されるので、統計の表をコピペして、Excelの      空きシートに一時的に貼り付けます。 (6)フィルタを追加して、品詞で名詞を選択してフィルタリングします。名詞のみのデータになるの      で、フィルタしたシートのB列(出現数)、C列(表記)をコピーして退避し、B列とC列を入れ替え

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

-
イメージ
1.はじめに 仕事や趣味でいろいろなデータを扱いますが、プログラミングで扱うデータ形式も多種多様でデータベース、テキスト、csv、xml、json形式など 思い付くだけで数十種類でてきます。データの見える化 (可視化) をやりたくて階層構造のJSON形式のファイルを扱う必要性があり、 元データ収集・編集 ⇒ Excelでデータ作成 ⇒ CSV出力 ⇒ 階層構造のJSONファイルへ変換出力と言ったステップでJSONファイルを作成して見ましたので紹介致します。 2.階層構造CSVtoJSONコンバータ 最初は、テキストエディタで手作業でJSONファイルを作成しょうと試みましたが、{}の対応付けや[,などの挿入漏れなど ミスすることが多くてデータを読み込むとエラーで動かないことの連続でした。何とか効率良く元データより階層構造の JSON形式のファイルを作成することができないものかとネット検索しても意図したものを見つけ出すことが出来ませんでした。 そこで今回、試行錯誤してExcel VBAで作成した 「階層構造CSVtoJSONコンバータ」 によるデータ作成手順をまとめて見ました。 階層構造のJSONファイルとは、 親、子、孫、曾孫・・・といった 階層構造のデータ形式のァイル です。 2-1.データの収集について まずは、目的とすべき元となるデータを収集しなければなりません。データの入手や収集手段はいろいろあると思いますが、 1回限りでのみ利用する場合や不定期、日次、週次、月次など継続的に利用する場合に応じて効率良い方法を選択する必要があります。 企業では自社内の各種システムにて収集や加工・編集などができるツール類もあると思いますが、個人ではなかなか揃えられません。 尚、今回は小規模なデータを扱うことを前提としているので効率的なデータの収集方法などについては別の機会にでも考えていきたいと 思います。ここでは、 「階層構造CSVtoJSONコンバータ」 の説明のためのテストデータを利用しての手順について説明します。 2-2.作成手順 (1)元データの準備 (テスト用に鳥類目録データの一部を利用) (2)Excelで元データを利用して、階層構造のデータ表を作成する。     ※【お願い】ファイルの終端判定のため、A列の末尾のセルにEOFと追記して下

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

-
イメージ
1.概要 最近は、Excel VBAやPythonなどによる自動化というキーワードを良く耳にしますが、昔からある自動化で最も安定性が あり、比較的単純な手順の記述とコマンド発行といったコマンドプロンプトによる操作およびバッチファイルによる自動処理 があります。システムの運用管理者やネットワーク管理者の人達も多く利用されています。 筆者も一時期は、良く利用していましたがGUIの操作に慣れ過ぎて最近は利用する機会も減ってきています。 今回は、HSP言語によるコマンドプロンプトを操作して外部から文字列(コマンド)を送信する方法を模索して見たいと思います。 2.コマンドプロンプトに文字列送信 コマンドプロンプトにGUI画面上からキー入力された文字列を送信する方法について説明します。 まず、概略の処理の流れを整理します。 (1) コマンドプロンプトを起動させる。 ただし、環境依存を無くすため環境変数 'comspec' より取得したパス名を、 exec 命令のp1パラメータとして渡す。 (2) 入力ボックス等より入力したコマンド（ テキスト文字列 ）をクリップボードにコピーする。 (3) コマンドプロンプト画面をアクティブにする。 (4) クリップボードよりコマンドを貼り付ける。 整理すると、これらの処理を実現させるためには、 ・環境変数'comspec'よりパス名を取得する処理 ・クリップボードにテキスト文字列をコピーする処理 ・任意の画面をアクティブにする処理 ・クリップボードよりテキスト文字列を貼り付ける処理 となります。ここで、一番難しいのはコンソールに対してクリップボードよりテキスト文字列を貼り付ける処理です。 [ ALT ]+[ SP ]+[ e ]+[ p ]+[ Enter ] キーという操作を keybd_event APIを 利用 して送り、貼り付け処理をしても良いのですが、メニューの操作をエミュレートするので、 [ ALT ]+[ SP ] で メニュー がポップアップし、次に [ e ] で編集がクリックされ、更に [ p ]+[ Enter ] キーといった流れとなって メニューの 操作が丸見えとなります。もちろん、動作的にも遅くスマートではありません。 コマンド

TOP