ExcelVBAマクロ exce.liveクラウドのデモ紹介(GPSプロッタ)

プログラミング

3月に「ExcelVBAマクロ exce.liveクラウドのデモ紹介」で「3Dモデル回転」を紹介しました。

その後、新たに「GPSプロッタ」を作成して公開したのでこちらも紹介します。

exce.liveクラウドのデモ

exce.liveクラウドの公式ページにてVBAidとコラボしたデモを公開中です。

exce.live デモサンプル - エクセリブ クラウド
exce.live サンプルデモ 定期的に、exce.liveクラウドをつかったサンプルプログラムを公開してい

現時点では僕が作成した第六弾「GPSプロッタ」までが公開されています。

「GPSプロッタ」の全体構成

「GPSプロッタ」は前回作成した「3Dモデル回転」と同様の構成になっています。

送信する情報が回転角度から緯度経度に変わっただけです。

送信用ページはHTML形式でJavaScriptを埋め込み、スマホのGPSから緯度経度を取得し、その情報をexce.liveクラウドへメッセージ送信します。

受信用Excelがそのメッセージを受信するとシートチェンジイベントが実行され、受け取ったメッセージの値に合わせて地図上にマーカーをプロットしています。

「3Dモデル回転」同様この構成の中作成したのはHTMLファイル1つとExcelファイル1つだけです。

個人的にexce.liveクラウドとスマホはかなり相性の良い組み合わせだと思います。

ソース解説

ソースはデモページからダウンロードできます。

送信用HTML

送信用HTMLはJavaScriptを埋め込んでいます。

順番に何をやっているかを解説していきます。

<!DOCTYPE html>
<html>
<head>
<title>GPSプロッタ(送信側)</title>
<meta http-equiv="content-type" charset="UTF-8">
<script>

    var token = "";
    var cur_interval = 0;
    var cur_next = 0;
    var cur_id;
    var cur_latitude;
    var cur_longitude;
    var cur_altitude;
    var cur_accuracy;
    var cur_altitudeAccuracy;
    var cur_heading;
    var cur_speed;
    var cur_time;
    var cur_num = 0;

    function clearWatchPosition() {
        navigator.geolocation.clearWatch(watchID);
    }

    function getGPS(pos) {
        cur_latitude = pos.coords.latitude;
        cur_longitude = pos.coords.longitude;
        cur_altitude = pos.coords.altitude;
        cur_accuracy = pos.coords.accuracy;
        cur_altitudeAccuracy = pos.coords.altitudeAccuracy;
        cur_heading = pos.coords.heading;
        cur_speed = pos.coords.speed;
        let date = new Date(pos.timestamp);
        cur_time = date.toLocaleString();
        cur_num += 1;
        let sHtml;
        sHtml = "";
        sHtml += "緯度:" + cur_latitude + "\n";
        sHtml += "経度:" + cur_longitude + "\n";
        sHtml += "高度:" + cur_altitude + "\n";
        sHtml += "位置精度:" + cur_accuracy + "\n";
        sHtml += "高度精度:" + cur_altitudeAccuracy + "\n";
        sHtml += "移動方向:" + cur_heading + "\n";
        sHtml += "速度:" + cur_speed + "\n";
        sHtml += "取得時刻:" + cur_time + "\n";
        sHtml += "取得回数:" + cur_num + "\n";
        document.getElementById("nowInfo").innerHTML = sHtml;
    }

    function sendInfo() {
        let dInterval = document.getElementById("interval").value;
        if (cur_interval != dInterval) {
            cur_interval = dInterval;
            cur_next = dInterval;
        }
        cur_next -= 1;
        if (cur_next == 0) {
            let bStop = document.getElementsByName("options")[0].checked;
            let sHtml;
            sHtml = "";
            if (bStop) {
                sHtml += "送信を止めています\n";
                document.getElementById("sendInfo").innerHTML = sHtml;
            } else {
                cur_id = document.getElementById("uID").value;

                sHtml += "ID:" + cur_id + "\n";
                sHtml += "緯度:" + cur_latitude + "\n";
                sHtml += "経度:" + cur_longitude + "\n";
                sHtml += "高度:" + cur_altitude + "\n";
                sHtml += "位置精度:" + cur_accuracy + "\n";
                sHtml += "高度精度:" + cur_altitudeAccuracy + "\n";
                sHtml += "移動方向:" + cur_heading + "\n";
                sHtml += "速度:" + cur_speed + "\n";
                sHtml += "取得時刻:" + cur_time + "\n";
                sHtml += "取得回数:" + cur_num + "\n";
                document.getElementById("sendInfo").innerHTML = sHtml;

                let sUrl = "";
                sUrl += "https://api.exce.live/sendmsg?";
                sUrl += "token=" + token + "&";
                sUrl += "sheet=newsheet&";
                sUrl += "msg=";
                sUrl += cur_id + ",";
                sUrl += cur_latitude + ",";
                sUrl += cur_longitude + ",";
                sUrl += cur_altitude + ",";
                sUrl += cur_accuracy + ",";
                sUrl += cur_altitudeAccuracy + ",";
                sUrl += cur_heading + ",";
                sUrl += cur_speed + ",";
                sUrl += cur_time + ",";
                sUrl += cur_num;
                sendMsg(sUrl);
            }
            cur_next = dInterval;
        } else {
        }
        let sDebugInfo = "";
        sDebugInfo += "ID:" + document.getElementById("uID").value + "<br>";
        sDebugInfo += "送信間隔:" + document.getElementById("interval").value + "<br>";
        sDebugInfo += "cur_interval:" + cur_interval + "<br>";
        sDebugInfo += "cur_next:" + cur_next + "<br>";
        document.getElementById("debugInfo").innerHTML = sDebugInfo;
    }

    function sendMsg(message) {

        var date = new Date();
        var cur_time = date.toLocaleString();

        document.getElementById('excelive_date').innerHTML = message;

        var req = new XMLHttpRequest();
        req.open('GET', message);
        req.onreadystatechange = function(event){
            if(req.readyState == 4){
                var text = document.getElementById('result');
                if(req.status == 200){
                    text.innerHTML = req.responseText;
                } else {
                    text.innerHTML = '送信完了[' + cur_time + ']';
                }
            }
        };
        req.send();
    }

    window.onload = function() {

        var queryString = window.location.search;
        console.log(queryString);
        var queryObject = new Object();
        if(queryString){
            queryString = queryString.substring(1);
            var parameters = queryString.split('&');

            for (var i = 0; i < parameters.length; i++) {
                var element = parameters[i].split('=');

                var paramName = decodeURIComponent(element[0]);
                var paramValue = decodeURIComponent(element[1]);

                queryObject[paramName] = paramValue;
            }

            token = queryObject.token;
            console.log(token);
        }

        if ((token==undefined) || (token=="")) {
            document.body.innerHTML = 'tokenをセットしてください';
        } else {
            //現在位置の取得開始
            watchID = navigator.geolocation.watchPosition(getGPS, null, {enableHighAccuracy:true});
            setInterval(sendInfo, 1000);
        }

    }

</script>
</head>
<body>
<br>
<!-- 個別情報 -->
 ID: <input type="text" id="uID" value="Unknown" required minlength="4" maxlength="8" size="10"><br>
送信間隔:
<select id="interval">
<option value="1">1秒</option>
<option value="5">5秒</option>
<option value="10">10秒</option>
<option value="15">15秒</option>
<option value="30" selected>30秒</option>
<option value="60">60秒</option>
</select>
<br>
<input type="checkbox" name="options" value="止める" checked> 情報の送信を止める<br>
<br>
<!-- 位置情報 -->
【現在の位置情報】<br>
<pre id="nowInfo"></pre>
【送信した位置情報】<br>
<pre id="sendInfo"></pre>
【exce.liveへ送信した内容】<br>
<pre id="excelive_date"></pre>
<br>
<br>
<!-- デバッグ用 -->
<!--
【デバッグ用】
<input type="button" value="定期的な位置情報の取得を停止" onclick="clearWatchPosition()" /><br>
<input type="button" value="情報更新" onclick="updateInfo()" /><br>
<pre id="debugInfo"></pre>
-->

<div style="text-align:center;">
<img src="https://account.exce.live/excelive_vbaid.jpg" width="90%">
</div>

</body>
</html>

GPS情報取得

スマホなどのハードウェア側のGPSの値をここで取得します。

GPSの値には緯度経度以外にも高度、移動方向、速度などの情報も取得できます。

取得タイミングはハードウェアに任せているため等間隔で行っているワケではありません。

確認のために取得したGPS情報はページに表示しています。

情報送信処理

送信する情報をページに表示しています。

GPSの情報取得タイミングと情報送信タイミングは非同期で実装したかったのでGPS取得時の情報とは別に送信時の情報を表示するようにしています。

実際の情報送信はこのあとの「メッセージ送信処理」で行っています。

メッセージ送信処理

exce.liveを使って送信をしています。

送信する内容は「情報送信処理」でページに表示した情報です。

送信用URLは既に組み立ててあるのでそれを使って送信しています。

レスポンスによって何かリアクションする必要が無かったため送るだけの実装にしました。

ページ表示処理

ページ表示のために読み込んだタイミングで必要な初期処理を行っています。

URLのパラメータから送信トークンを取得したりGPS情報取得の準備をしています。

受信用Excel

受信用Excelはシートのチェンジイベントでマクロが実行するようにしています。

これはexce.liveクラウドからExcelへ受信すると受信用シートの内容が更新されるため、シートのチェンジイベントを利用する事でexce.liveクラウドからメッセージを受信するタイミングでマクロを実行する事ができます。

受信した情報はシートに出力されているのでこの情報を一旦集めてGPSプロッタへ活用しています。

メインモジュール

イベントに対してまずはここを呼ばれるように作りました。(「地図」シート除く)

'*****************************************
'*
'*  メインモジュール(mMain)
'*
'*  各処理の開始用などのモジュール
'*
'*****************************************
Option Explicit

'描画モード
Public Enum drawMode
    dmRealTime = 0  'リアルタイムモード
    dmLog = 1       'ログモード
End Enum

Public dMode As drawMode

'exce.liveデータ受信時に行う処理
Public Sub funcReceive()
    'wsNewSheetからGPS情報を取得する
    Dim cGPSInfo As New clsGPSInfo
    Dim cNewSheetCtrl As New clsNewSheetCtrl
    Call cNewSheetCtrl.getGPSInfo(cGPSInfo)
    '受信データが無効の場合は以降の処理を行わない
    If cGPSInfo.bIsEnable = False Then Exit Sub
    'wsGPSlogへGPS情報を追加する
    Dim cGPSlogCtrl As New clsGPSlogCtrl
    Call cGPSlogCtrl.addGPSlog(cGPSInfo)
    'リアルタイムモード時は最新データで地図を更新
    If dMode = dmRealTime Then
        Dim cMapCtrl As clsMapCtrl
        Set cMapCtrl = New clsMapCtrl
        Call cMapCtrl.updateRealTime
    End If
End Sub

'ログをクリアする
Public Sub clearLog()
    Dim cGPSlogCtrl As New clsGPSlogCtrl
    Call cGPSlogCtrl.clearGPSlog
End Sub

'データをCSVで出力する
Public Sub exportCSV()
    Dim cGPSlogCtrl As New clsGPSlogCtrl
    Call cGPSlogCtrl.exportCSV
End Sub

受信したデータは「GPSログ」シートへ保管していきます。

リアルタイムモードでは同時に「地図」シートへの描画更新処理を呼び出しています。

「GPSログ」シート上に配置したボタン「クリア」「CSV出力」押下時に各処理の呼び出しも行っています。

地図オプションフォームモジュール

「地図」シートの「オプション」ボタン押下で表示されるフォームの処理です。

Option Explicit

Private cMapCtrl As clsMapCtrl

Private colAllGPSInfo As Collection

'フォーム初期処理
Private Sub UserForm_Initialize()
    Set cMapCtrl = New clsMapCtrl
    Call updateAllGPSLogInfo
    Call updateEnable
    Call initCmbZoomLevel
    Call initCmbID
    Call initSlbTime
    mMain.dMode = dmRealTime
    Call cMapCtrl.updateRealTime
End Sub

'フォーム終了処理
Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    mMain.dMode = dmRealTime
    Call cMapCtrl.updateRealTime
    Call cMapCtrl.clearMapLog
End Sub

'リアルタイムモード選択時
Private Sub obRealTime_Click()
    Call updateEnable
    mMain.dMode = dmRealTime
    Set cMapCtrl = New clsMapCtrl
    Call cMapCtrl.updateRealTime
    Call cMapCtrl.clearMapLog
End Sub

'ログモード選択時
Private Sub obLog_Click()
    Call updateEnable
    If colAllGPSInfo Is Nothing Then
        Me.slbTime.Enabled = False
        Exit Sub
    Else
        Me.slbTime.Enabled = True
    End If
    mMain.dMode = dmLog
    Call cMapCtrl.prepareLogMap
    Call cMapCtrl.updateLog
    Dim cGPSInfo As clsGPSInfo
    Set cGPSInfo = colAllGPSInfo.Item(Me.slbTime.Value)
    Call cMapCtrl.putLogTarget(cGPSInfo)
End Sub

'ズームレベル変更時
Private Sub cmbZoomLevel_Change()
    Set cMapCtrl = New clsMapCtrl
    Call cMapCtrl.updateRealTime
End Sub

'ID変更時
Private Sub cmbID_Change()
    Set cMapCtrl = New clsMapCtrl
    Call cMapCtrl.updateRealTime
End Sub

'IDリスト更新ボタン押下時
Private Sub cmdUpdateIDList_Click()
    Call updateAllGPSLogInfo
    Call initCmbID
End Sub

'時間スクロールバー変更時
Private Sub slbTime_Change()
    Dim cGPSInfo As clsGPSInfo
    Set cGPSInfo = colAllGPSInfo.Item(Me.slbTime.Value)
    Me.lblTime.Caption = cGPSInfo.sReceive
    If Me.slbTime.Enabled Then
        Call cMapCtrl.putLogTarget(cGPSInfo)
    End If
End Sub

'全GPSログ情報を更新(本プロシージャ内Public変数)
Private Sub updateAllGPSLogInfo()
    Dim cGPSlogCtrl As clsGPSlogCtrl
    Set cGPSlogCtrl = New clsGPSlogCtrl
    Set colAllGPSInfo = cGPSlogCtrl.getAllGPSInfo()
End Sub

'ズームレベルコンボボックスの初期化
Private Sub initCmbZoomLevel()
    Dim i As Long
    For i = 0 To 18
        Call Me.cmbZoomLevel.AddItem(i)
    Next
    Me.cmbZoomLevel.ListIndex = 16
End Sub

'IDコンボボックスの初期化
Private Sub initCmbID()
    If colAllGPSInfo Is Nothing Then Exit Sub
    Call Me.cmbID.Clear
    Dim colIDList As Collection
    Set colIDList = New Collection
    Call colIDList.Add("")  '全対象用に空白を最初に追加しておく
    Dim cGPSInfo As clsGPSInfo
    For Each cGPSInfo In colAllGPSInfo
        On Error Resume Next
            Call colIDList.Add(cGPSInfo.sID, cGPSInfo.sID)
        On Error GoTo 0
    Next
    Dim i As Long
    For i = 1 To colIDList.Count
        Call Me.cmbID.AddItem(colIDList.Item(i))
    Next
    Me.cmbID.ListIndex = 0
End Sub

'時間スクロールバーの初期化
Private Sub initSlbTime()
    If colAllGPSInfo Is Nothing Then Exit Sub
    Me.slbTime.Min = 1
    Me.slbTime.Max = colAllGPSInfo.Count
End Sub

'各コントローラの有効/無効更新
Private Sub updateEnable()
    Me.frameRealTime.Enabled = Me.obRealTime.Value
    Me.lblZoomLevel.Enabled = Me.obRealTime.Value
    Me.cmbZoomLevel.Enabled = Me.obRealTime.Value
    Me.lblID.Enabled = Me.obRealTime.Value
    Me.cmbID.Enabled = Me.obRealTime.Value
    Me.cmdUpdateIDList.Enabled = Me.obRealTime.Value
    Me.frameLog.Enabled = Not Me.obRealTime.Value
    Me.lblTime.Enabled = Not Me.obRealTime.Value
    Me.slbTime.Enabled = Not Me.obRealTime.Value
End Sub

ここでは各コントローラの操作を情報として取得しています。

実際にその操作に対応する動作の処理はクラス側で実装しています。

MVCモデルを意識した作りにしてみました。

「GPSログ」シート操作クラスモジュール

「GPSログ」シートの操作をまとめたクラスモジュールです。

'*****************************************
'*
'*  「GPSログ」シート操作クラス(clsGPSlogCtrl)
'*
'*****************************************
Option Explicit

Private Const ROW_INDEX_TITLE As Long = 3   'GPSログタイトル行
Private Const ROW_INDEX_START As Long = 4   'GPSログ開始行

Private Const COL_INDEX_NO As Long = 2
Private Const COL_INDEX_RECEIVE_DATE As Long = 3
Private Const COL_INDEX_ID As Long = 4
Private Const COL_INDEX_LATITUDE As Long = 5
Private Const COL_INDEX_LONGITUDE As Long = 6
Private Const COL_INDEX_ALTITUDE As Long = 7
Private Const COL_INDEX_ACCURACY As Long = 8
Private Const COL_INDEX_ALTITUDE_ACCURACY As Long = 9
Private Const COL_INDEX_HEADING As Long = 10
Private Const COL_INDEX_SPEED As Long = 11
Private Const COL_INDEX_TIME As Long = 12
Private Const COL_INDEX_COUNT As Long = 13

Private Const COUNT_ITEM As Long = COL_INDEX_COUNT - COL_INDEX_NO + 1

'GPSログを一覧の最終行に追加する
Public Sub addGPSlog(ByRef cGPSInfo As clsGPSInfo)
    '追加行(最終行の次)を取得する
    Dim lRow As Long
    lRow = getLastRow() + 1
    'GPS情報を書き込む
    Call writeGPSInfo(lRow, cGPSInfo)
End Sub

'GPSログの一覧をクリアする
Public Sub clearGPSlog()
    '最終行を取得する
    Dim lRow As Long
    lRow = getLastRow()
    '最終行が開始行より小さい場合は既にクリアしているので以降の処理を行わない
    If lRow < ROW_INDEX_START Then Exit Sub
    '開始行から最終行までの範囲を削除する
    Call wsGPSlog.Rows(ROW_INDEX_START & ":" & lRow).Delete(Shift:=xlUp)
End Sub

'GPSログの一覧をCSVで出力する
Public Sub exportCSV()
    'データを集める
    Dim lLastRow As Long
    lLastRow = getLastRow()
    Dim rStart As Excel.Range
    Set rStart = wsGPSlog.Cells(ROW_INDEX_TITLE, COL_INDEX_NO)
    Dim rLast As Excel.Range
    Set rLast = wsGPSlog.Cells(lLastRow, COL_INDEX_COUNT)
    Dim arrayGPSlog
    arrayGPSlog = Range(rStart, rLast).Value
    'データが無い場合は処理を行わない
    If UBound(arrayGPSlog, 1) <= 1 Then Exit Sub
    
    '規定のファイル名は「GPSログ_」+日時とする
    Dim sInitFileName As String
    sInitFileName = "GPSログ_" & Format(Now, "YYYYMMDD-hhmmss") & ".csv"
    Dim FileName As Variant
    FileName = Application.GetSaveAsFilename(InitialFileName:=sInitFileName, FileFilter:="CSVファイル,*.csv")
    If FileName = False Then
        Exit Sub
    End If
    
    'データをCSVで保存
    Dim FSO As Scripting.FileSystemObject
    Set FSO = New Scripting.FileSystemObject
    Dim tsCSV As Scripting.TextStream
    Set tsCSV = FSO.OpenTextFile(FileName, ForWriting, True)
    Dim i As Long
    Dim j As Long
    For i = LBound(arrayGPSlog, 1) To UBound(arrayGPSlog, 1)
        Dim sLineData As String
        sLineData = ""
        For j = LBound(arrayGPSlog, 2) To UBound(arrayGPSlog, 2)
            sLineData = sLineData & arrayGPSlog(i, j) & ","
        Next
        sLineData = Left(sLineData, Len(sLineData) - Len(","))
        Call tsCSV.WriteLine(sLineData)
        Debug.Print sLineData
    Next
    Call tsCSV.Close
    Set tsCSV = Nothing
End Sub

'緯度経度の最大値、最小値を取得
'※データが0件の場合は空白文字(0バイト)を返す
Public Function getMaxLat() As String
    '最終行を取得
    Dim lLastRow As Long
    lLastRow = getLastRow()
    '最終行まで緯度最大値の更新を行う
    Dim dMaxLat As Double
    dMaxLat = -90
    Dim lRow As Long
    For lRow = ROW_INDEX_START To lLastRow
        Dim dLat As Double
        dLat = CDbl(wsGPSlog.Cells(lRow, COL_INDEX_LATITUDE).Value)
        '緯度最大値更新
        If dLat > dMaxLat Then
            dMaxLat = dLat
            getMaxLat = CStr(dMaxLat)
        End If
    Next
End Function
Public Function getMinLat() As String
    '最終行を取得
    Dim lLastRow As Long
    lLastRow = getLastRow()
    '最終行まで緯度最小値の更新を行う
    Dim dMinLat As Double
    dMinLat = 90
    Dim lRow As Long
    For lRow = ROW_INDEX_START To lLastRow
        Dim dLat As Double
        dLat = CDbl(wsGPSlog.Cells(lRow, COL_INDEX_LATITUDE).Value)
        '緯度最小値更新
        If dLat < dMinLat Then
            dMinLat = dLat
            getMinLat = CStr(dMinLat)
        End If
    Next
End Function
Public Function getMaxLng() As String
    '最終行を取得
    Dim lLastRow As Long
    lLastRow = getLastRow()
    '最終行まで経度最大値の更新を行う
    Dim dMaxLng As Double
    dMaxLng = -180
    Dim lRow As Long
    For lRow = ROW_INDEX_START To lLastRow
        Dim dLng As Double
        dLng = CDbl(wsGPSlog.Cells(lRow, COL_INDEX_LONGITUDE).Value)
        '経度最大値更新
        If dLng > dMaxLng Then
            dMaxLng = dLng
            getMaxLng = CStr(dMaxLng)
        End If
    Next
End Function
Public Function getMinLng() As String
    '最終行を取得
    Dim lLastRow As Long
    lLastRow = getLastRow()
    '最終行まで経度最小値の更新を行う
    Dim dMinLng As Double
    dMinLng = 180
    Dim lRow As Long
    For lRow = ROW_INDEX_START To lLastRow
        Dim dLng As Double
        dLng = CDbl(wsGPSlog.Cells(lRow, COL_INDEX_LONGITUDE).Value)
        '経度最小値更新
        If dLng < dMinLng Then
            dMinLng = dLng
            getMinLng = CStr(dMinLng)
        End If
    Next
End Function

'最新GPS情報を取得する
Public Function getLatestGPSInfo(Optional ByVal sID As String = "") As clsGPSInfo
'Public Function getLatestGPSInfo() As clsGPSInfo
    '初期値としてNothingを設定する
    Set getLatestGPSInfo = Nothing
    '最終行を取得する
    Dim lLastRow As Long
    lLastRow = getLastRow()
    Dim lRow As Long
    If sID = "" Then
        'IDが空白(指定無しの全てが対象)の場合は最終行を対象行とする
        lRow = lLastRow
    Else
        '最終行から該当のIDのうち最も最近の情報行を特定する
        For lRow = lLastRow To ROW_INDEX_TITLE Step -1
            If wsGPSlog.Cells(lRow, COL_INDEX_ID).Value = sID Then Exit For
        Next
        If lRow = ROW_INDEX_TITLE Then Exit Function
    End If
    '最終行の情報をGPS情報クラスへ格納して返す
    Dim cGPSInfo As clsGPSInfo
    Set cGPSInfo = New clsGPSInfo
    With wsGPSlog
        cGPSInfo.sReceive = .Cells(lRow, COL_INDEX_RECEIVE_DATE)
        cGPSInfo.sID = .Cells(lRow, COL_INDEX_ID)
        cGPSInfo.sLatitude = .Cells(lRow, COL_INDEX_LATITUDE)
        cGPSInfo.sLongitude = .Cells(lRow, COL_INDEX_LONGITUDE)
        cGPSInfo.sAltitude = .Cells(lRow, COL_INDEX_ALTITUDE)
        cGPSInfo.sAccuracy = .Cells(lRow, COL_INDEX_ACCURACY)
        cGPSInfo.sAltitudeAccuracy = .Cells(lRow, COL_INDEX_ALTITUDE_ACCURACY)
        cGPSInfo.sHeading = .Cells(lRow, COL_INDEX_HEADING)
        cGPSInfo.sSpeed = .Cells(lRow, COL_INDEX_SPEED)
        cGPSInfo.sTime = .Cells(lRow, COL_INDEX_TIME)
        cGPSInfo.sCount = .Cells(lRow, COL_INDEX_COUNT)
        cGPSInfo.bIsEnable = IsNumeric(cGPSInfo.sLatitude) And IsNumeric(cGPSInfo.sLongitude)
    End With
    Set getLatestGPSInfo = cGPSInfo
End Function

'全情報を取得する(データが無い場合はNothingが戻る)
Public Function getAllGPSInfo() As Collection
    Dim colAllGPSInfo As Collection
    Set colAllGPSInfo = New Collection
    
    '初期値として戻り値をNothingにしておく
    Set getAllGPSInfo = Nothing
    
    '最終行を取得する
    Dim lLastRow As Long
    lLastRow = getLastRow()
    'データが無い場合はNothingのまま戻す
    If lLastRow <= ROW_INDEX_TITLE Then Exit Function
    'データを集める
    Dim lRow As Long
    For lRow = ROW_INDEX_START To lLastRow
        Dim cGPSInfo As clsGPSInfo
        Set cGPSInfo = New clsGPSInfo
        With cGPSInfo
            .sReceive = wsGPSlog.Cells(lRow, COL_INDEX_RECEIVE_DATE)
            .sID = wsGPSlog.Cells(lRow, COL_INDEX_ID)
            .sLatitude = wsGPSlog.Cells(lRow, COL_INDEX_LATITUDE)
            .sLongitude = wsGPSlog.Cells(lRow, COL_INDEX_LONGITUDE)
            .sAltitude = wsGPSlog.Cells(lRow, COL_INDEX_ALTITUDE)
            .sAccuracy = wsGPSlog.Cells(lRow, COL_INDEX_ACCURACY)
            .sAltitudeAccuracy = wsGPSlog.Cells(lRow, COL_INDEX_ALTITUDE_ACCURACY)
            .sHeading = wsGPSlog.Cells(lRow, COL_INDEX_HEADING)
            .sSpeed = wsGPSlog.Cells(lRow, COL_INDEX_SPEED)
            .sTime = wsGPSlog.Cells(lRow, COL_INDEX_TIME)
            .sCount = wsGPSlog.Cells(lRow, COL_INDEX_COUNT)
            .bIsEnable = IsNumeric(.sLatitude) And IsNumeric(.sLongitude)
        End With
        Call colAllGPSInfo.Add(cGPSInfo)
    Next
    Set getAllGPSInfo = colAllGPSInfo
End Function

'最終行を取得する
'※最終行の判定は「№」(B列)で行う
Private Function getLastRow() As Long
    '№のセルから「Ctrl+↓」で特定する最終行を取得する
    Dim rNoCell As Excel.Range
    Set rNoCell = wsGPSlog.Cells(ROW_INDEX_START - 1, COL_INDEX_NO)
    Dim rNoLastCell As Excel.Range
    Set rNoLastCell = rNoCell.End(xlDown)
    '※データが何も無い場合にはExcel制限の最終行になるため№が空白の場合は最終行を開始行の1つ上の行とする
    Dim lLastRow As Long
    If rNoLastCell.Value = "" Then
        lLastRow = ROW_INDEX_START - 1
    Else
        lLastRow = rNoLastCell.Row
    End If
    getLastRow = lLastRow
End Function

'GPS情報を書き込む
Private Sub writeGPSInfo(ByVal lRow As Long, ByRef cGPSInfo As clsGPSInfo)
    With wsGPSlog
        .Cells(lRow, COL_INDEX_NO).Value = lRow - ROW_INDEX_START + 1
        .Cells(lRow, COL_INDEX_RECEIVE_DATE).Value = cGPSInfo.sReceive
        .Cells(lRow, COL_INDEX_ID).Value = cGPSInfo.sID
        .Cells(lRow, COL_INDEX_LATITUDE).Value = cGPSInfo.sLatitude
        .Cells(lRow, COL_INDEX_LONGITUDE).Value = cGPSInfo.sLongitude
        .Cells(lRow, COL_INDEX_ALTITUDE).Value = cGPSInfo.sAltitude
        .Cells(lRow, COL_INDEX_ACCURACY).Value = cGPSInfo.sAccuracy
        .Cells(lRow, COL_INDEX_ALTITUDE_ACCURACY).Value = cGPSInfo.sAltitudeAccuracy
        .Cells(lRow, COL_INDEX_HEADING).Value = cGPSInfo.sHeading
        .Cells(lRow, COL_INDEX_SPEED).Value = cGPSInfo.sSpeed
        .Cells(lRow, COL_INDEX_TIME).Value = cGPSInfo.sTime
        .Cells(lRow, COL_INDEX_COUNT).Value = cGPSInfo.sCount
    End With
End Sub

「GPSログ」シートへの追加、クリアを実装しています。

CSVへの出力もここで実装しています。

「地図」シートの地図範囲を知る必要があるため一覧から緯度経度の最大値、最小値を取得できるようにしています。

最新情報のプロッタも必要なのでID指定で最新の情報取得もできるようにしています。

「地図」シートで経路表示に利用するため、全情報を取得する機能も実装しています。

「地図」シート操作クラスモジュール

「地図」シートの操作をまとめたクラスモジュールです。

'*****************************************
'*
'*  「地図」シート操作クラス(clsMapCtrl)
'*
'*****************************************
Option Explicit

'地図用シェイプ名
'2桁の数字はXY座標方向のインデックスで「0」開始
'配置イメージ
' ┏━┳━┳━┓
' ┃00┃10┃20┃
' ┣━╋━╋━┫
' ┃01┃11┃21┃
' ┣━╋━╋━┫
' ┃02┃12┃22┃
' ┗━┻━┻━┛
Private Const NAME_MAP_00 As String = "Map_00"
Private Const NAME_MAP_10 As String = "Map_10"
Private Const NAME_MAP_20 As String = "Map_20"
Private Const NAME_MAP_01 As String = "Map_01"
Private Const NAME_MAP_11 As String = "Map_11"
Private Const NAME_MAP_21 As String = "Map_21"
Private Const NAME_MAP_02 As String = "Map_02"
Private Const NAME_MAP_12 As String = "Map_12"
Private Const NAME_MAP_22 As String = "Map_22"

'セル名
Private Const CELL_NAME_ZOOM_LEVEL As String = "ズームレベル"
Private Const CELL_NAME_IN_TILE_X As String = "タイル内座標X"
Private Const CELL_NAME_IN_TILE_Y As String = "タイル内座標Y"
Private Const CELL_NAME_TILE_X As String = "タイルX"
Private Const CELL_NAME_TILE_Y As String = "タイルY"
Private Const CELL_NAME_PIXEL_X As String = "ピクセルX"
Private Const CELL_NAME_PIXEL_Y As String = "ピクセルY"
Private Const CELL_NAME_LATITUDE As String = "緯度"
Private Const CELL_NAME_LONGITUDE As String = "経度"

'地図のサイズ(ピクセル数)
Private Const MAP_SIZE As Long = 256

'ZXY情報クラス(clsZXYInfo)
Private cZXYInfo As clsZXYInfo
'前回ZXY情報クラス(clsZXYInfo)
Private cZXYInfoPrev As clsZXYInfo

'ZXY情報用セル(デバッグ用)
Private rZoomLevel As Excel.Range
Private rInTileX As Excel.Range
Private rInTileY As Excel.Range
Private rTileX As Excel.Range
Private rTileY As Excel.Range
Private rPixelX As Excel.Range
Private rPixelY As Excel.Range
Private rLatitude As Excel.Range
Private rLongitude As Excel.Range

'地図用シェイプ
Private srMap00 As ShapeRange
Private srMap10 As ShapeRange
Private srMap20 As ShapeRange
Private srMap01 As ShapeRange
Private srMap11 As ShapeRange
Private srMap21 As ShapeRange
Private srMap02 As ShapeRange
Private srMap12 As ShapeRange
Private srMap22 As ShapeRange

'地図中心情報
Private lZ As Long  'ズームレベル
Private lX As Long  'タイル座標X
Private lY As Long  'タイル座標Y

Private colPrevInfo As Collection   '前回情報

'初期処理
Private Sub Class_Initialize()
    'ZXY情報クラス(clsZXYInfo)を生成する
    Set cZXYInfo = New clsZXYInfo
    Set cZXYInfoPrev = New clsZXYInfo
    'マップ用ShapeRangeを取得する
    Set srMap00 = wsMap.Shapes.Range(Array(NAME_MAP_00))
    Set srMap10 = wsMap.Shapes.Range(Array(NAME_MAP_10))
    Set srMap20 = wsMap.Shapes.Range(Array(NAME_MAP_20))
    Set srMap01 = wsMap.Shapes.Range(Array(NAME_MAP_01))
    Set srMap11 = wsMap.Shapes.Range(Array(NAME_MAP_11))
    Set srMap21 = wsMap.Shapes.Range(Array(NAME_MAP_21))
    Set srMap02 = wsMap.Shapes.Range(Array(NAME_MAP_02))
    Set srMap12 = wsMap.Shapes.Range(Array(NAME_MAP_12))
    Set srMap22 = wsMap.Shapes.Range(Array(NAME_MAP_22))
    '情報用セルを取得する
    Set rZoomLevel = wsMap.Range(CELL_NAME_ZOOM_LEVEL)
    Set rInTileX = wsMap.Range(CELL_NAME_IN_TILE_X)
    Set rInTileY = wsMap.Range(CELL_NAME_IN_TILE_Y)
    Set rTileX = wsMap.Range(CELL_NAME_TILE_X)
    Set rTileY = wsMap.Range(CELL_NAME_TILE_Y)
    Set rPixelX = wsMap.Range(CELL_NAME_PIXEL_X)
    Set rPixelY = wsMap.Range(CELL_NAME_PIXEL_Y)
    Set rLatitude = wsMap.Range(CELL_NAME_LATITUDE)
    Set rLongitude = wsMap.Range(CELL_NAME_LONGITUDE)
End Sub

'リアルタイムモードの更新処理
Public Sub updateRealTime()
    Dim cGPSlogCtrl As clsGPSlogCtrl
    Set cGPSlogCtrl = New clsGPSlogCtrl
    Dim cGPSInfo As clsGPSInfo
    Set cGPSInfo = cGPSlogCtrl.getLatestGPSInfo(frmOption.cmbID.Value)
    '最新データが無効の場合は以降の処理を行わない
    If cGPSInfo.bIsEnable = False Then Exit Sub
    Call updateMap(cGPSInfo, frmOption.cmbZoomLevel.Value)
End Sub

'ログモードの地図準備
Public Sub prepareLogMap()
    Dim cGPSlogCtrl As clsGPSlogCtrl
    Set cGPSlogCtrl = New clsGPSlogCtrl
    'GPSログの緯度経度の最大値、最小値を取得
    Dim dMaxLat As Double
    dMaxLat = cGPSlogCtrl.getMaxLat
    Dim dMinLat As Double
    dMinLat = cGPSlogCtrl.getMinLat
    Dim dMaxLng As Double
    dMaxLng = cGPSlogCtrl.getMaxLng
    Dim dMinLng As Double
    dMinLng = cGPSlogCtrl.getMinLng
    Debug.Print "dMaxLat:" & dMaxLat
    Debug.Print "dMinLat:" & dMinLat
    Debug.Print "dMaxLng:" & dMaxLng
    Debug.Print "dMinLng:" & dMinLng
    'ズームレベルを18から下げていってタイル座標差2になるところを最適ズームレベルとする
    Dim lZL As Long
    Dim lTileXMax As Long
    Dim lTileYMax As Long
    Dim lTileXMin As Long
    Dim lTileYMin As Long
    For lZL = 18 To 0 Step -1
        Dim cZXYInfoMax As clsZXYInfo
        Set cZXYInfoMax = New clsZXYInfo
        Call cZXYInfoMax.setLatLngZL(dMaxLat, dMaxLng, lZL)
        Dim cZXYInfoMin As clsZXYInfo
        Set cZXYInfoMin = New clsZXYInfo
        Call cZXYInfoMin.setLatLngZL(dMinLat, dMinLng, lZL)
        lTileXMax = cZXYInfoMax.TileX
        lTileYMax = cZXYInfoMax.TileY
        lTileXMin = cZXYInfoMin.TileX
        lTileYMin = cZXYInfoMin.TileY
        If Abs(lTileXMax - lTileXMin) < 3 And Abs(lTileYMax - lTileYMin) < 3 Then Exit For
    Next
    Debug.Print "最大タイル座標(" & lZL & "):" & lTileXMax & "," & lTileYMax
    Debug.Print "最小タイル座標(" & lZL & "):" & lTileXMin & "," & lTileYMin
    Dim lTileXInterval As Long
    lTileXInterval = lTileXMax - lTileXMin
    Dim lTileYInterval As Long
    lTileYInterval = lTileYMin - lTileYMax
    Debug.Print "タイル座標差(" & lZL & "):" & lTileXInterval & "," & lTileYInterval
    Dim lTileXOffset As Long
    lTileXOffset = lTileXInterval / 2
    Dim lTileYOffset As Long
    lTileYOffset = lTileYInterval / 2
    Dim lTileXCenter As Long
    lTileXCenter = lTileXMin + lTileXOffset
    Dim lTileYCenter As Long
    lTileYCenter = lTileYMax + lTileYOffset
    Debug.Print "中心タイル座標(" & lZL & "):" & lTileXCenter & "," & lTileYCenter
    '中心タイル座標で地図を更新して最新情報にターゲットを置く
    Dim cGPSInfo As clsGPSInfo
    Set cGPSInfo = cGPSlogCtrl.getLatestGPSInfo()
    Call updateMap(cGPSInfo, lZL)
    Call updateMapPic(lZL, lTileXCenter, lTileYCenter)
End Sub

'ログモードの更新処理
Public Sub updateLog()
    Dim cGPSlogCtrl As clsGPSlogCtrl
    Set cGPSlogCtrl = New clsGPSlogCtrl
    Dim cGPSInfo As clsGPSInfo
    'ログの情報を取得する
    Dim colAllGPSInfo As Collection
    Set colAllGPSInfo = cGPSlogCtrl.getAllGPSInfo()
    For Each cGPSInfo In colAllGPSInfo
        Debug.Print cGPSInfo.sReceive & "," & cGPSInfo.sLatitude & "," & cGPSInfo.sLongitude
        Dim cZXYInfo As clsZXYInfo
        Set cZXYInfo = New clsZXYInfo
        Call cZXYInfo.setLatLngZL(cGPSInfo.sLatitude, cGPSInfo.sLongitude, lZ)
        Debug.Print cZXYInfo.TileX & "," & cZXYInfo.TileY
        Dim lOffsetPixelX As Long
        lOffsetPixelX = (cZXYInfo.TileX - lX) * MAP_SIZE
        Dim lOffsetPixelY As Long
        lOffsetPixelY = (cZXYInfo.TileY - lY) * MAP_SIZE
        Debug.Print lOffsetPixelX & "," & lOffsetPixelY
        Dim dInTileX As Double
        dInTileX = cZXYInfo.InTileX + lOffsetPixelX
        Dim dInTileY As Double
        dInTileY = cZXYInfo.InTileY + lOffsetPixelY
        Debug.Print dInTileX & "," & dInTileY
        Call addPt(cGPSInfo.sID, dInTileX, dInTileY)
    Next
End Sub

'ログ上にターゲットを配置する
Public Sub putLogTarget(ByRef cGPSInfo As clsGPSInfo)
    Dim cZXYInfo As clsZXYInfo
    Set cZXYInfo = New clsZXYInfo
    Call cZXYInfo.setLatLngZL(cGPSInfo.sLatitude, cGPSInfo.sLongitude, lZ)
    Dim lOffsetPixelX As Long
    lOffsetPixelX = (cZXYInfo.TileX - lX) * MAP_SIZE
    Dim lOffsetPixelY As Long
    lOffsetPixelY = (cZXYInfo.TileY - lY) * MAP_SIZE
    Dim dInTileX As Double
    dInTileX = cZXYInfo.InTileX + lOffsetPixelX
    Dim dInTileY As Double
    dInTileY = cZXYInfo.InTileY + lOffsetPixelY
    Call putTarget(dInTileX, dInTileY)
End Sub

'マップを更新する
Public Sub updateMap(ByRef cGPSInfo As clsGPSInfo, ByVal lZL As Long)
    'GPS情報とズームレベルでZXY情報を設定する
    With cGPSInfo
        Call cZXYInfo.setLatLngZL(CDbl(.sLatitude), CDbl(.sLongitude), lZL)
    End With
    'シートにZXY情報を出力する
    Call outputZXYInfo
    'マップのレイアウトを整理する
    Call layoutMap
    'ズームレベル、タイル座標に変化が無い場合は更新不要
    If Not cZXYInfo.isMatchZXY(cZXYInfoPrev) Then
        '地図画像をZXY情報に合わせて更新する
        Call updateMapPic
    End If
    'ターゲットを配置する
    Call putTarget
    '今回の情報を前回情報として設定しておく
    Set cZXYInfoPrev = cZXYInfo
End Sub

'ログを削除する
Public Sub clearMapLog()
    Dim i As Long
    Dim shapeTmp As Excel.Shape
    For i = wsMap.Shapes.Count To 1 Step -1
        Set shapeTmp = wsMap.Shapes.Item(i)
        If InStr(1, shapeTmp.Name, "ログ") = 1 Then
            Call shapeTmp.Delete
        End If
    Next
    Set colPrevInfo = New Collection
End Sub

'シートにZXY情報を出力する
Private Sub outputZXYInfo()
    With cZXYInfo
        rZoomLevel.Value = .ZoomLevel
        rInTileX.Value = .InTileX
        rInTileY.Value = .InTileY
        rTileX.Value = .TileX
        rTileY.Value = .TileY
        rPixelX.Value = .PixelX
        rPixelY.Value = .PixelY
        rLatitude.Value = .Latitude
        rLongitude.Value = .Longitude
    End With
End Sub

'マップのレイアウトを整理する
'※マップの配置が崩れた場合はこれで整列する
'※設定前に整列要否判定を行い不要な整列は行わない
Private Sub layoutMap(Optional ByVal dX As Double = 0, Optional ByVal dY As Double = 0)
    Dim dSetX As Double
    Dim dSetY As Double
    With srMap00
        dSetX = dX + 0
        dSetY = dY + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap10
        dSetX = srMap00.Left + MAP_SIZE
        dSetY = srMap00.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap20
        dSetX = srMap10.Left + MAP_SIZE
        dSetY = srMap10.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap01
        dSetX = srMap00.Left + 0
        dSetY = srMap00.Top + MAP_SIZE
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap11
        dSetX = srMap01.Left + MAP_SIZE
        dSetY = srMap01.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap21
        dSetX = srMap11.Left + MAP_SIZE
        dSetY = srMap11.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap02
        dSetX = srMap01.Left + 0
        dSetY = srMap01.Top + MAP_SIZE
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap12
        dSetX = srMap02.Left + MAP_SIZE
        dSetY = srMap02.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
    With srMap22
        dSetX = srMap12.Left + MAP_SIZE
        dSetY = srMap12.Top + 0
        If .Left <> dSetX Then .Left = dSetX
        If .Top <> dSetY Then .Top = dSetY
    End With
End Sub

'地図画像をZXY情報に合わせて更新する
'※ズームレベル、タイル座標に変化が無い場合は更新しない
'※地図画像は国土交通省の国土地理院が提供しているWeb APIを利用
' http://cyberjapandata.gsi.go.jp/xyz/std/{z}/{x}/{y}.png
'地図は3x3の9枚構成で指定タイル座標を中心に以下の座標オフセットを行って地図を更新する
' ┏━━━━━┳━━━━━┳━━━━━┓
' ┃(00) -1,-1┃(10) +0,-1┃(20) +1,-1┃
' ┣━━━━━╋━━━━━╋━━━━━┫
' ┃(01) -1,+0┃(11) +0,+0┃(21) +1,+0┃
' ┣━━━━━╋━━━━━╋━━━━━┫
' ┃(02) -1,+1┃(12) +0,+1┃(22) +1,+1┃
' ┗━━━━━┻━━━━━┻━━━━━┛
Private Sub updateMapPic(Optional ByVal lZL As Long = -1, Optional ByVal lTileXCenter As Long = -1, Optional ByVal lTileYCenter As Long = -1)
    '基点の情報を取得
    If lZL >= 0 Then
        lZ = lZL
    Else
        lZ = cZXYInfo.ZoomLevel
    End If
    If lTileXCenter >= 0 Then
        lX = lTileXCenter
    Else
        lX = cZXYInfo.TileX
    End If
    If lTileYCenter >= 0 Then
        lY = lTileYCenter
    Else
        lY = cZXYInfo.TileY
    End If
    Dim sURL As String
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX - 1) & "/" & CStr(lY - 1) & ".png"
    Call srMap00.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 0) & "/" & CStr(lY - 1) & ".png"
    Call srMap10.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 1) & "/" & CStr(lY - 1) & ".png"
    Call srMap20.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX - 1) & "/" & CStr(lY + 0) & ".png"
    Call srMap01.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 0) & "/" & CStr(lY + 0) & ".png"
    Call srMap11.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 1) & "/" & CStr(lY + 0) & ".png"
    Call srMap21.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX - 1) & "/" & CStr(lY + 1) & ".png"
    Call srMap02.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 0) & "/" & CStr(lY + 1) & ".png"
    Call srMap12.Fill.UserPicture(sURL)
    sURL = "https://cyberjapandata.gsi.go.jp/xyz/std/" & CStr(lZ) & "/" & CStr(lX + 1) & "/" & CStr(lY + 1) & ".png"
    Call srMap22.Fill.UserPicture(sURL)
End Sub

'ターゲットを配置する
'※ターゲットは中心の地図にタイル内座標を使って配置する
Private Sub putTarget(Optional ByVal dInTileX As Double = -300, Optional ByVal dInTileY As Double = -300)
    Dim shapeTarget As Object
    Set shapeTarget = wsMap.Shapes.Range(Array("ターゲット"))
    '配置先タイル左上座標を取得
    Dim dGenX As Double
    dGenX = srMap11.Left
    Dim dGenY As Double
    dGenY = srMap11.Top
    'タイル内座標がターゲットの中心になるように設定
    If dInTileX = -300 Then
        shapeTarget.Left = dGenX + cZXYInfo.InTileX - (shapeTarget.Width / 2)
    Else
        shapeTarget.Left = dGenX + dInTileX - (shapeTarget.Width / 2)
    End If
    If dInTileY = -300 Then
        shapeTarget.Top = dGenY + cZXYInfo.InTileY - (shapeTarget.Height / 2)
    Else
        shapeTarget.Top = dGenY + dInTileY - (shapeTarget.Height / 2)
    End If
End Sub

'点を追加する
Private Sub addPt(ByVal sID As String, ByVal dInTileX As Double, ByVal dInTileY As Double)
    '点を作成
    Dim cPrevInfo As clsPrevInfo
    On Error Resume Next
        Set cPrevInfo = colPrevInfo.Item(sID)
        If CBool(Err) Then
            Set cPrevInfo = New clsPrevInfo
            Call colPrevInfo.Add(cPrevInfo, sID)
            Call Err.Clear
        End If
    On Error GoTo 0
    cPrevInfo.lCount = cPrevInfo.lCount + 1
    Dim shapePt As Excel.Shape
    Set shapePt = wsMap.Shapes.AddShape(msoShapeMathMultiply, 0, 0, 70, 70)
    Call shapePt.ScaleWidth(0.2, msoFalse, msoScaleFromTopLeft)
    Call shapePt.ScaleHeight(0.2, msoFalse, msoScaleFromTopLeft)
    shapePt.Name = "ログ点" & cPrevInfo.lCount
    '配置先タイル左上座標を取得
    Dim dGenX As Double
    dGenX = srMap11.Left
    Dim dGenY As Double
    dGenY = srMap11.Top
    'タイル内座標が点の中心になるように設定
    shapePt.Left = dGenX + dInTileX - (shapePt.Width / 2)
    shapePt.Top = dGenY + dInTileY - (shapePt.Height / 2)
    '2つ目以降は経路用の線も追加する
    If cPrevInfo.lCount > 1 Then
        Dim shapeLine As Excel.Shape
        Set shapeLine = wsMap.Shapes.AddConnector(msoConnectorStraight, dGenX + cPrevInfo.dPrevInTileX, dGenY + cPrevInfo.dPrevInTileY, dGenX + dInTileX, dGenY + dInTileY)
        With shapeLine.Line
            .ForeColor.RGB = RGB(255, 0, 0)
            .Weight = 2
        End With
        shapeLine.Name = "ログ線" & cPrevInfo.lCount
    End If
    '前回情報として保持しておく
    cPrevInfo.dPrevInTileX = dInTileX
    cPrevInfo.dPrevInTileY = dInTileY
End Sub

「地図」シートの地図更新やその地図上の緯度経度と一致する位置にターゲットを配置する処理をこのクラスで行っています。

リアルタイムモードでは指定IDの最新情報を元に「地図」シートを更新します。

ログモードでは全受信データを使って3×3で組み合わせた地図上からはみ出ないように地図の更新と経路を結んだプロットで「地図」シートを更新します。

ZXY情報クラスモジュール

「地図」シートの操作をまとめたクラスモジュールです。

'*****************************************
'*
'*  ZXY情報クラス(clsZXYInfo)
'*
'*  緯度経度から地図データを取得するためには
'*  ズームレベル、ピクセル座標、タイル座標への
'*  変換が必要。
'*  このクラスではズームレベルと緯度経度から
'*  ピクセル座標、タイル座標を計算するための
'*  機能を実装している。
'*  ※参考ページ
'*  https://www.trail-note.net/tech/coordinate/
'*
'*****************************************
Option Explicit

'タイル座標確認ページ
'https://maps.gsi.go.jp/development/tileCoordCheck.html#5/35.371/138.735

'Google Mapsで表示可能な緯度の最大値(定数)。Lは約85度。Google Maps APIではこの地点より北極側は表示できない。南極も同様。
Private Const VALUE_LONGITUDE_MAX As Double = 85.05112878

Private lZoomLevel As Long      'ズームレベル
Private dInTileX As Double      'タイル内座標X
Private dInTileY As Double      'タイル内座標Y
Private lTileX As Long          'タイル座標X
Private lTileY As Long          'タイル座標Y
Private dPixelX As Double       'ピクセル座標X
Private dPixelY As Double       'ピクセル座標Y
Private dLatitude As Double     '緯度
Private dLongitude As Double    '経度

'円周率(π)(クラスの初期化時に設定)
Private pi As Double

'初期化
Private Sub Class_Initialize()
    '円周率を設定
    pi = 4 * Atn(1)
End Sub

'緯度経度ズームレベルを設定する
Public Sub setLatLngZL(ByVal dLat As Double, ByVal dLng As Double, lZL As Long)
    'ズームレベルを設定する
    lZoomLevel = lZL
    '緯度経度を設定する
    dLatitude = dLat
    dLongitude = dLng
    '計算して情報を更新する
    'ピクセル座標
    dPixelX = 2 ^ (lZoomLevel + 7) * ((dLongitude / 180) + 1)
    dPixelY = (2 ^ (lZoomLevel + 7) / pi) * (-1 * funcAtanh(Sin(pi / 180 * dLatitude)) + funcAtanh(Sin(VALUE_LONGITUDE_MAX * pi / 180)))
    'タイル座標
    lTileX = pixel2tile(dPixelX)
    lTileY = pixel2tile(dPixelY)
    'タイル内座標
    dInTileX = getInTile(dPixelX)
    dInTileY = getInTile(dPixelY)
End Sub

'ズームレベル、タイル座標に変化が無いか判定する(True:一致、False:不一致)
Public Function isMatchZXY(ByRef cZXYInfo As clsZXYInfo) As Boolean
    '初期値として不一致にしておく
    isMatchZXY = False
    'ズームレベル、タイル座標が1つでも一致しない場合は処理を抜ける
    With cZXYInfo
        If .ZoomLevel <> lZoomLevel Then Exit Function
        If .TileX <> lTileX Then Exit Function
        If .TileY <> lTileY Then Exit Function
    End With
    'ズームレベル、タイル座標が全て一致したとして一致(True)を返す
    isMatchZXY = True
End Function

'プロパティ(読み取り専用)
'※各値は「setLatLngZL()」プロシージャにて算出&設定する
Public Property Get ZoomLevel() As Long
    ZoomLevel = lZoomLevel
End Property
Public Property Get Latitude() As Double
    Latitude = dLatitude
End Property
Public Property Get Longitude() As Double
    Longitude = dLongitude
End Property
Public Property Get PixelX() As Double
    PixelX = dPixelX
End Property
Public Property Get PixelY() As Double
    PixelY = dPixelY
End Property
Public Property Get TileX() As Long
    TileX = lTileX
End Property
Public Property Get TileY() As Long
    TileY = lTileY
End Property
Public Property Get InTileX() As Double
    InTileX = dInTileX
End Property
Public Property Get InTileY() As Double
    InTileY = dInTileY
End Property

'逆双曲線正接(ATANH)
'※Excel関数を利用
Private Function funcAtanh(ByVal dValue As Double) As Double
    funcAtanh = Excel.Application.WorksheetFunction.Atanh(dValue)
End Function

'ピクセル座標⇒タイル座標変換
Private Function pixel2tile(ByVal dPixel As Double) As Long
    pixel2tile = funcRoundDown(dPixel / 256)
End Function

'ピクセル座標⇒タイル内座標取得
Private Function getInTile(ByVal dPixel As Double) As Double
    '※Modでは小数点以下が切り捨てられてしまうため、小数点以下の数字をあらかじめ保持しておく
    Dim dDecimal As Double
    dDecimal = dPixel - CLng(dPixel)
    getInTile = (dPixel Mod 256) + dDecimal
End Function

'小数点以下切り捨て
'※Excel関数を利用
Private Function funcRoundDown(ByVal dValue As Double) As Double
    funcRoundDown = Excel.Application.WorksheetFunction.RoundDown(dValue, 0)
End Function

「地図」シートの地図は国土交通省地理院で提供されているAPIを利用しています。

このAPIを使うためには緯度経度の情報では使えなくズームレベルとそのズームレベルに合ったタイル座標値が必要になってきます。

そのため緯度経度からズームレベル&タイル座標値に変換させる処理が必要になります。

このクラスではこれら面倒な処理を一手に引き受けるように実装しました。

まとめ

「GPSプロッタ」は前回紹介した「3Dモデル回転」と構成は一致していますがExcel VBA側のプログラムはかなり大きくなってしまいました。

地図についてはGoogle Mapを当初考えていましたがAPIの無料提供が終わっていたので代わりに国土交通省地理院の地図データを使いました。

国土交通省地理院なら有料化される心配もないと思うので恐らくずっと無料で使えると思います。

緯度経度とズームレベルからタイル座標変換が出来るようになったので今後地図データを使いたい場面があれば国土交通省地理院のAPIを使っていこうと思います。

気力があればここら辺の情報を整理して記事にしたいかな。

コメント

タイトルとURLをコピーしました