3月に「ExcelVBAマクロ exce.liveクラウドのデモ紹介」で「3Dモデル回転」を紹介しました。
その後、新たに「GPSプロッタ」を作成して公開したのでこちらも紹介します。
exce.liveクラウドのデモ
exce.liveクラウドの公式ページにてVBAidとコラボしたデモを公開中です。
exce.live デモサンプル - エクセリブ クラウド
ダウンロード サンプルプログラム (xlsm形式) 856KB ※PCにダウンロードし、ご自身のアカウントの認
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を使っていこうと思います。
気力があればここら辺の情報を整理して記事にしたいかな。
コメント