Excelのデータを用いてGoogle Earthにプレイスマークをプロット

Excelに入力された位置情報データを用いて，Google Earth上にプレイスマークをプロットさせることが出来れば，簡易なGISとして活用することが可能となります。以下では，橋梁の点検結果から評価した健全度をマッピングしてみることにします。

1 はじめに
2 モジュールの作成
- 2.1 何をするプロシージャか
- 2.2 プロシージャのコード
3 何が起こっているか
4 おわりに

はじめに

ケーススタディ

橋梁の健全度マップを作成するケーススタディを行います。緯度経度はある自治体の橋梁位置の一部を拝借しましたが，ケーススタディのため，橋梁名，健全度ランクは適当です。

動作確認状況

Excel	32ビット	64ビット
2007	OK	–
2010	たぶんOK（未確認）	たぶんOK（未確認）
2011 Mac	NG	–
2013	OK	OK

~~2007, 2013の32ビットでしか動作確認していませんが、Win32APIを用いていないので、おそらく64ビットでもそのまま動くでしょう。~~

2007, 2013の32ビットおよび2013の64ビットで動作確認しました。MSXMLの参照設定があるため、2011 Macでは動作しません。

データの準備

上図のように，’Sheet1′ 上に ‘テーブル1’ を作成し，列として「橋梁名」「緯度」「経度」「ランク」を設定します。この場合のランクは下表の様に設定しています。

健全度ランク	橋梁の健全性	マーク
1	健全で補修の必要がない
2	損傷があり，計画的な補修が必要
3	損傷が大きく，緊急的な対応が必要

モジュールの作成

標準モジュールにパブリックプロシージャを1つ作成します。

何をするプロシージャか

Excelのテーブルから橋梁名、位置情報（緯度、経度）、健全度を取得して、健全度別に色が異なるアイコンのプレイスマークをkmlファイルとして作成し、Google Earth上にプロットします。

プロシージャのコード

ケーススタディのため，実行部分のソースコードのみ記載します。ボタンやメニューは必要に応じて作成して下さい。

Option Explicit

Sub LaunchGoogleEarth() 'エクセルのデータを加工してGoogle Earthに表示
    
    '使用するテーブルを指定
    Dim lst As ListObject
    Set lst = ThisWorkbook.Worksheets("Sheet1").ListObjects("テーブル1")

    'XMLファイルを作成　要参照設定 Microdoft XML, v6.0
    Dim XmlDoc As MSXML2.DOMDocument60
    Set XmlDoc = New MSXML2.DOMDocument60
    
    'XML宣言を設定
    Dim xmlPI As MSXML2.IXMLDOMProcessingInstruction
    Set xmlPI = XmlDoc.appendChild(XmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"))
        
    'kmlルートノードを設定
    Dim RootNode As MSXML2.IXMLDOMElement
    Set RootNode = XmlDoc.createElement("kml")
    Set XmlDoc.DocumentElement = RootNode

    'kmlドキュメント設定
    Dim DocumentElement As MSXML2.IXMLDOMElement
    Dim tmpElement As MSXML2.IXMLDOMElement
    Set DocumentElement = AddElement(XmlDoc, RootNode, "Document")
        Set tmpElement = AddElement(XmlDoc, DocumentElement, "name", "Temporary")

    'マーカースタイル設定
    Dim Style As Variant
    Dim StyleElement As MSXML2.IXMLDOMElement
    Dim PairElement As MSXML2.IXMLDOMElement
    Dim IconStyleElement As MSXML2.IXMLDOMElement
    Dim IconElement As MSXML2.IXMLDOMElement
        
    For Each Style In Array("red", "grn", "ylw")
        Set StyleElement = AddElement(XmlDoc, DocumentElement, "StyleMap", , "id", "msn_" & Style & "-pushpin")
            Set PairElement = AddElement(XmlDoc, StyleElement, "Pair")
                Set tmpElement = AddElement(XmlDoc, PairElement, "key", "normal")
                Set tmpElement = AddElement(XmlDoc, PairElement, "styleUrl", "#sn_" & Style & "-pushpin")
            Set PairElement = AddElement(XmlDoc, StyleElement, "Pair")
                Set tmpElement = AddElement(XmlDoc, PairElement, "key", "highlight")
                Set tmpElement = AddElement(XmlDoc, PairElement, "styleUrl", "#sh_" & Style & "-pushpin")
        
        Set StyleElement = AddElement(XmlDoc, DocumentElement, "Style", , "id", "sn_" & Style & "-pushpin")
            Set IconStyleElement = AddElement(XmlDoc, StyleElement, "IconStyle")
                Set tmpElement = AddElement(XmlDoc, IconStyleElement, "scale", "1.1")
                Set IconElement = AddElement(XmlDoc, IconStyleElement, "Icon")
                    Set tmpElement = AddElement(XmlDoc, IconElement, "href", "http://maps.google.com/mapfiles/kml/pushpin/" & Style & "-pushpin.png")
                Set tmpElement = AddElement(XmlDoc, IconStyleElement, "hotSpot", , "x", "20", "y", "2", "xunits", "pixels", "yunits", "pixels")
                
        Set StyleElement = AddElement(XmlDoc, DocumentElement, "Style", , "id", "sh_" & Style & "-pushpin")
            Set IconStyleElement = AddElement(XmlDoc, StyleElement, "IconStyle")
                Set tmpElement = AddElement(XmlDoc, IconStyleElement, "scale", "1.3")
                Set IconElement = AddElement(XmlDoc, IconStyleElement, "Icon")
                    Set tmpElement = AddElement(XmlDoc, IconElement, "href", "http://maps.google.com/mapfiles/kml/pushpin/" & Style & "-pushpin.png")
                Set tmpElement = AddElement(XmlDoc, IconStyleElement, "hotSpot", , "x", "20", "y", "2", "xunits", "pixels", "yunits", "pixels")
    Next Style
    
    'テーブルの内容によってプレイスマークを追加
    Dim Bridge As Variant
    Dim R As Long
    Dim BridgeName As String
    Dim lat As Double, lng As Double
    Dim lng_lat As String
    Dim lRank As Long, sRank As String
    Dim Desc As String
    Dim PlacemarkElement As MSXML2.IXMLDOMElement
    Dim PointElement As MSXML2.IXMLDOMElement
    Dim LookAtElement As MSXML2.IXMLDOMElement
        
    With lst
        'テーブルで見えている橋を対象（フィルタで隠したものは表示しない）
        For Each Bridge In .ListColumns("橋梁名").DataBodyRange.SpecialCells(xlCellTypeVisible)
            
            R = Bridge.Row '対象の橋の行番号
            BridgeName = .ListColumns("橋梁名").Range(R) '橋梁名
            lat = .ListColumns("緯度").Range(R) '緯度
            lng = .ListColumns("経度").Range(R) '経度
            lng_lat = CStr(lng) & "," & CStr(lat) & ",0" '緯度＋経度＋高度(0)
            lRank = .ListColumns("ランク").Range(R) 'ランク（整数）
            
            'ランクに対応するスタイルマップを指定
            Select Case lRank
                Case 1: sRank = "#msn_grn-pushpin"
                Case 2: sRank = "#msn_ylw-pushpin"
                Case 3: sRank = "#msn_red-pushpin"
            End Select
            
            'ポップアップで出す説明文（HTML）を設定
            Desc = "橋梁名:" & BridgeName & "<br/>" & "ランク:" & lRank
                                
            'プレイスマークを設定
            Set PlacemarkElement = AddElement(XmlDoc, DocumentElement, "Placemark")
                Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "name", "") 'アイコンの横に名前を表示しない
                Set LookAtElement = AddElement(XmlDoc, PlacemarkElement, "LookAt")
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "longitude", CStr(lng))
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "latitude", CStr(lat))
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "altitude", "0")
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "heading", "1")
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "range", "500")
                    Set tmpElement = AddElement(XmlDoc, LookAtElement, "gx:altitudeMode", "relativeToSeaFloor")
                Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "description", Desc)
                Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "styleUrl", sRank)
                Set PointElement = AddElement(XmlDoc, PlacemarkElement, "Point")
                    Set tmpElement = AddElement(XmlDoc, PointElement, "coordinates", lng_lat)
        Next Bridge
    End With

    'テンポラリフォルダを作成
    If Dir("C:\Temp", vbDirectory) = "" Then MkDir "C:\Temp"
 
    'テンポラリフォルダにXMLを書き出し（拡張子はkml）
    XmlDoc.Save ("C:\Temp\Temp.kml")

    '作成したkmlを開く（要Google Earthのインストール）
    Dim WSH
    Set WSH = CreateObject("Wscript.Shell")
        WSH.Run "C:\Temp\Temp.kml", 3
        
    Set lst = Nothing
    Set XmlDoc = Nothing
    Set xmlPI = Nothing
    Set RootNode = Nothing
    Set DocumentElement = Nothing
    Set StyleElement = Nothing
    Set PairElement = Nothing
    Set IconStyleElement = Nothing
    Set IconElement = Nothing
    Set PlacemarkElement = Nothing
    Set PointElement = Nothing
    Set LookAtElement = Nothing
    Set tmpElement = Nothing
    Set WSH = Nothing

End Sub

100

101

102

103

104

105

106

107

108

109

110

111

112

113

114

115

116

117

118

119

120

121

122

123

124

125

126

127

128

129

130

131

132

133

134

135

Option Explicit

Sub LaunchGoogleEarth() 'エクセルのデータを加工してGoogle Earthに表示

'使用するテーブルを指定

Dim lst As ListObject

Set lst = ThisWorkbook.Worksheets("Sheet1").ListObjects("テーブル1")

'XMLファイルを作成　要参照設定 Microdoft XML, v6.0

Dim XmlDoc As MSXML2.DOMDocument60

Set XmlDoc = New MSXML2.DOMDocument60

'XML宣言を設定

Dim xmlPI As MSXML2.IXMLDOMProcessingInstruction

Set xmlPI = XmlDoc.appendChild(XmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"))

'kmlルートノードを設定

Dim RootNode As MSXML2.IXMLDOMElement

Set RootNode = XmlDoc.createElement("kml")

Set XmlDoc.DocumentElement = RootNode

'kmlドキュメント設定

Dim DocumentElement As MSXML2.IXMLDOMElement

Dim tmpElement As MSXML2.IXMLDOMElement

Set DocumentElement = AddElement(XmlDoc, RootNode, "Document")

Set tmpElement = AddElement(XmlDoc, DocumentElement, "name", "Temporary")

'マーカースタイル設定

Dim Style As Variant

Dim StyleElement As MSXML2.IXMLDOMElement

Dim PairElement As MSXML2.IXMLDOMElement

Dim IconStyleElement As MSXML2.IXMLDOMElement

Dim IconElement As MSXML2.IXMLDOMElement

For Each Style In Array("red", "grn", "ylw")

Set StyleElement = AddElement(XmlDoc, DocumentElement, "StyleMap", , "id", "msn_" & Style & "-pushpin")

Set PairElement = AddElement(XmlDoc, StyleElement, "Pair")

Set tmpElement = AddElement(XmlDoc, PairElement, "key", "normal")

Set tmpElement = AddElement(XmlDoc, PairElement, "styleUrl", "#sn_" & Style & "-pushpin")

Set PairElement = AddElement(XmlDoc, StyleElement, "Pair")

Set tmpElement = AddElement(XmlDoc, PairElement, "key", "highlight")

Set tmpElement = AddElement(XmlDoc, PairElement, "styleUrl", "#sh_" & Style & "-pushpin")

Set StyleElement = AddElement(XmlDoc, DocumentElement, "Style", , "id", "sn_" & Style & "-pushpin")

Set IconStyleElement = AddElement(XmlDoc, StyleElement, "IconStyle")

Set tmpElement = AddElement(XmlDoc, IconStyleElement, "scale", "1.1")

Set IconElement = AddElement(XmlDoc, IconStyleElement, "Icon")

Set tmpElement = AddElement(XmlDoc, IconElement, "href", "http://maps.google.com/mapfiles/kml/pushpin/" & Style & "-pushpin.png")

Set tmpElement = AddElement(XmlDoc, IconStyleElement, "hotSpot", , "x", "20", "y", "2", "xunits", "pixels", "yunits", "pixels")

Set StyleElement = AddElement(XmlDoc, DocumentElement, "Style", , "id", "sh_" & Style & "-pushpin")

Set IconStyleElement = AddElement(XmlDoc, StyleElement, "IconStyle")

Set tmpElement = AddElement(XmlDoc, IconStyleElement, "scale", "1.3")

Set IconElement = AddElement(XmlDoc, IconStyleElement, "Icon")

Set tmpElement = AddElement(XmlDoc, IconElement, "href", "http://maps.google.com/mapfiles/kml/pushpin/" & Style & "-pushpin.png")

Set tmpElement = AddElement(XmlDoc, IconStyleElement, "hotSpot", , "x", "20", "y", "2", "xunits", "pixels", "yunits", "pixels")

Next Style

'テーブルの内容によってプレイスマークを追加

Dim Bridge As Variant

Dim R As Long

Dim BridgeName As String

Dim lat As Double, lng As Double

Dim lng_lat As String

Dim lRank As Long, sRank As String

Dim Desc As String

Dim PlacemarkElement As MSXML2.IXMLDOMElement

Dim PointElement As MSXML2.IXMLDOMElement

Dim LookAtElement As MSXML2.IXMLDOMElement

With lst

'テーブルで見えている橋を対象（フィルタで隠したものは表示しない）

For Each Bridge In .ListColumns("橋梁名").DataBodyRange.SpecialCells(xlCellTypeVisible)

R = Bridge.Row '対象の橋の行番号

BridgeName = .ListColumns("橋梁名").Range(R) '橋梁名

lat = .ListColumns("緯度").Range(R) '緯度

lng = .ListColumns("経度").Range(R) '経度

lng_lat = CStr(lng) & "," & CStr(lat) & ",0" '緯度＋経度＋高度(0)

lRank = .ListColumns("ランク").Range(R) 'ランク（整数）

'ランクに対応するスタイルマップを指定

Select Case lRank

Case 1: sRank = "#msn_grn-pushpin"

Case 2: sRank = "#msn_ylw-pushpin"

Case 3: sRank = "#msn_red-pushpin"

End Select

'ポップアップで出す説明文（HTML）を設定

Desc = "橋梁名:" & BridgeName & "<br/>" & "ランク:" & lRank

'プレイスマークを設定

Set PlacemarkElement = AddElement(XmlDoc, DocumentElement, "Placemark")

Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "name", "") 'アイコンの横に名前を表示しない

Set LookAtElement = AddElement(XmlDoc, PlacemarkElement, "LookAt")

Set tmpElement = AddElement(XmlDoc, LookAtElement, "longitude", CStr(lng))

Set tmpElement = AddElement(XmlDoc, LookAtElement, "latitude", CStr(lat))

Set tmpElement = AddElement(XmlDoc, LookAtElement, "altitude", "0")

Set tmpElement = AddElement(XmlDoc, LookAtElement, "heading", "1")

Set tmpElement = AddElement(XmlDoc, LookAtElement, "range", "500")

Set tmpElement = AddElement(XmlDoc, LookAtElement, "gx:altitudeMode", "relativeToSeaFloor")

Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "description", Desc)

Set tmpElement = AddElement(XmlDoc, PlacemarkElement, "styleUrl", sRank)

Set PointElement = AddElement(XmlDoc, PlacemarkElement, "Point")

Set tmpElement = AddElement(XmlDoc, PointElement, "coordinates", lng_lat)

Next Bridge

End With

'テンポラリフォルダを作成

If Dir("C:\Temp", vbDirectory) = "" Then MkDir "C:\Temp"

'テンポラリフォルダにXMLを書き出し（拡張子はkml）

XmlDoc.Save ("C:\Temp\Temp.kml")

'作成したkmlを開く（要Google Earthのインストール）

Dim WSH

Set WSH = CreateObject("Wscript.Shell")

WSH.Run "C:\Temp\Temp.kml", 3

Set lst = Nothing

Set XmlDoc = Nothing

Set xmlPI = Nothing

Set RootNode = Nothing

Set DocumentElement = Nothing

Set StyleElement = Nothing

Set PairElement = Nothing

Set IconStyleElement = Nothing

Set IconElement = Nothing

Set PlacemarkElement = Nothing

Set PointElement = Nothing

Set LookAtElement = Nothing

Set tmpElement = Nothing

Set WSH = Nothing

End Sub

何が起こっているか

上で作成したプロシージャの主要部分を説明します。

テーブルの設定

    Dim lst As ListObject
    Set lst = ThisWorkbook.Worksheets("Sheet1").ListObjects("テーブル1")

6 7	Dim lst As ListObject Set lst = ThisWorkbook.Worksheets("Sheet1").ListObjects("テーブル1")

対象とするテーブルをオブジェクト変数にセットします。下図のように ‘Sheet1’ 上に ‘テーブル1’ を作成しているのでこのようにします。

XMLファイル作成の準備

    'XMLファイルを作成　要参照設定 Microdoft XML, v6.0
    Dim XmlDoc As MSXML2.DOMDocument60
    Set XmlDoc = New MSXML2.DOMDocument60

'XMLファイルを作成　要参照設定 Microdoft XML, v6.0

Dim XmlDoc As MSXML2.DOMDocument60

Set XmlDoc = New MSXML2.DOMDocument60

xmlDocというオブジェクト変数に新しいXMLドキュメントを作成してセットします。このためにはXMLの参照設定が必要です。

XMLの書き出し

    'XML宣言を設定
    Dim xmlPI As MSXML2.IXMLDOMProcessingInstruction
    Set xmlPI = XmlDoc.appendChild(XmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"))

'XML宣言を設定

Dim xmlPI As MSXML2.IXMLDOMProcessingInstruction

Set xmlPI = XmlDoc.appendChild(XmlDoc.createProcessingInstruction("xml", "version='1.0' encoding='utf-8'"))

これにより、kmlファイル（実態はXMLファイル）の最初の部分（XMLの宣言）が作成されます。

<?xml version="1.0" encoding="UTF-8"?>

1	<?xml version="1.0" encoding="UTF-8"?>

kmlファイルの中身の作成

まず作成するxmlに、kmlというルートノードを追加します。
以下の部分で、

    'kmlルートノードを設定
    Dim RootNode As MSXML2.IXMLDOMElement
    Set RootNode = XmlDoc.createElement("kml")
    Set XmlDoc.DocumentElement = RootNode

'kmlルートノードを設定

Dim RootNode As MSXML2.IXMLDOMElement

Set RootNode = XmlDoc.createElement("kml")

Set XmlDoc.DocumentElement = RootNode

xmlはこのようになります。

<?xml version="1.0" encoding="UTF-8"?>
<kml>
</kml>

<?xml version="1.0" encoding="UTF-8"?>

<kml>

</kml>

次に、必要な要素を追加していきます。

    'kmlドキュメント設定
    Dim DocumentElement As MSXML2.IXMLDOMElement
    Dim tmpElement As MSXML2.IXMLDOMElement
    Set DocumentElement = AddElement(XmlDoc, RootNode, "Document")
        Set tmpElement = AddElement(XmlDoc, DocumentElement, "name", "Temporary")

'kmlドキュメント設定

Dim DocumentElement As MSXML2.IXMLDOMElement

Dim tmpElement As MSXML2.IXMLDOMElement

Set DocumentElement = AddElement(XmlDoc, RootNode, "Document")

Set tmpElement = AddElement(XmlDoc, DocumentElement, "name", "Temporary")

kmlルートノードの中に、Document要素を追加し、そのDocument要素にさらにname要素を追加し、Temporaryというテキストを追加します。

要素の追加や、その要素にテキストを追加する部分を記述するのは長くなるので、こちらのエントリで作成したAddelementという関数を用います。別の標準モジュールあるいは同じモジュールでもよいので、Functionプロシージャを追加します。

これにより、xmlの中身は以下のようになります。

<?xml version="1.0" encoding="UTF-8"?>
<kml>
    <Document>
        <name>Temporary</name>
    </Document>
</kml>

<?xml version="1.0" encoding="UTF-8"?>

<kml>

<name>Temporary</name>

</Document>

</kml>

以下、このような作業の繰り返しです。

35〜57行：赤、緑、黄のプッシュピンのスタイルを作成
71〜107行のループ：オートフィルタによって見えている行に対するループ
75〜80行：プロットする橋梁名、緯度経度、ランクなどを取得
83〜87行：ランクに応じて使用するスタイルを選定
90行：ポップアップする説明文を作成
93行〜105行：プレイスマークに必要なxmlを作成

93〜105行の部分で以下のようなxmlが作成されます。

    <Placemark>
        <name></name>
        <LookAt>
            <longitude>141.46667</longitude>
            <latitude>40.32500</latitude>
            <altitude>0</altitude>
            <heading>1</heading>
            <range>500</range>
            <gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>
        </LookAt>
        <Description>橋梁名:○○橋1<br/>ランク2</Description>
        <styleUrl>#msn_ylw-pushpin</styleUrl>
        <Point>
            <coordinates>141.46667,40.32500,0</coordinates>
        </Point>
    </Placemark>

<gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>

</LookAt>

<styleUrl>#msn_ylw-pushpin</styleUrl>

<Point>

</Point>

</Placemark>

kmlの各要素はリファレンスに説明があります。

ループが終わった後は、ソースコードのコメント欄にあるとおり、テンポラリフォルダを作成して、作成したxml文書をkmlファイルとして保存し、そのkmlファイルを起動し、Google Earthを立ち上げています。

おわりに

実行結果

作成したマクロを実行すると，XMLファイルが一時的に作成・起動され，Google Earth上に表示されます。

場所（プレイスマーク）パネルの各ポイントをクリックすると，その橋梁の位置へジャンプし，吹き出しに情報を表示させることが出来ます。

応用

今回はプレイスマークの例を挙げましたが、ライン要素に応用すれば、舗装の路面性状調査結果をプロットすることなども可能です。kmlの構造を読み解いて、是非チャレンジしてみてください。

ダウンロード

本エントリで作成した、「Excelのデータを用いてGoogle Earthにプレイスマークをプロット」するコードのサンプルファイルです。

本エントリからコピー＆ペーストしてご自身で作成することが可能ですが、面倒な方、やり方がわからない方はこちらをダウンロード下さい。

※ここにGumroadのウィジェットを表示していますが、企業・学校などでフィルタリングにより表示されない場合があります。