Google Earth批量生成地标文件（kml）的Excel VBA代码

据一哥们需求，要把N（N>20000）多点添加到google earth中，这么繁杂、重复的工作怎么能用体力来完成呢，于是向我求助。

整理的地标包括名称、东经、北纬等数据，存储在excel文件中（第一列为名称，第二列为东经，第三列为北纬，坐标以小数度为单位，而不是度分秒）。开始想用按键精灵，但发现要实现在excel对不同行取位置不好办。于是研究google earth，随意添加了两个地标，然后右键另存为kml文件，用emeditor打开，发现就是个xml格式的文件，里面包括了众多信息，当然坐标也在其中。据此，从这个kml文件入手开始计划用vba来生成这样一个文件。以前没接触过，简单分析了一下，只需要填入几个数据就OK。于是动手，代码如下：

 1 Sub GenPlacemark()
 2     Dim i As Integer
 3     Dim s As String '存储生成的代码
 4     Dim f as String '保存的文件名
 5     f="c:\point.kml"
 6     s = "<?xml version='1.0' encoding='UTF-8'?>" & Chr(10) & _
 7         "<kml xmlns='http://www.opengis.net/kml/2.2' xmlns:gx='http://www.google.com/kml/ext/2.2' xmlns:kml='http://www.opengis.net/kml/2.2' xmlns:atom='http://www.w3.org/2005/Atom'>" & Chr(10) & _
 8         "<Document>" & Chr(10) & _
 9         "<name>临时位置.kml</name>" & Chr(10) & _
10         "<StyleMap id='msn_ylw-pushpin'>" & Chr(10) & _
11         "<Pair>" & Chr(10) & _
12         "<key>normal</key>" & Chr(10) & _
13         "<styleUrl>#sn_ylw-pushpin</styleUrl>" & Chr(10) & _
14         "</Pair>" & Chr(10) & _
15         "<Pair>" & Chr(10) & _
16         "<key>highlight</key>" & Chr(10) & _
17         "<styleUrl>#sh_ylw-pushpin</styleUrl>" & Chr(10) & _
18         "</Pair>" & Chr(10) & _
19         "</StyleMap>"
20     s = s & "<Style id='sn_ylw-pushpin'>" & Chr(10) & _
21         "<IconStyle>" & Chr(10) & _
22         "<scale>1.1</scale>" & Chr(10) & _
23         "<Icon>" & Chr(10) & _
24         "<href>http://maps.google.com/mapfiles/kml/pushpin/ylw-pushpin.png</href>" & Chr(10) & _
25         "</Icon>" & Chr(10) & _
26         "<hotSpot x='20' y='2' xunits='pixels' yunits='pixels'/>" & Chr(10) & _
27         "</IconStyle>" & Chr(10) & _
28         "<ListStyle>" & Chr(10) & _
29        " </ListStyle>" & Chr(10) & _
30         "</Style>"
31     s = s & "<Style id='sh_ylw-pushpin'>" & Chr(10) & _
32         "<IconStyle>" & Chr(10) & _
33         "<scale>1.3</scale>" & Chr(10) & _
34         "<Icon>" & Chr(10) & _
35         "<href>http://maps.google.com/mapfiles/kml/pushpin/ylw-pushpin.png</href>" & Chr(10) & _
36         "</Icon>" & Chr(10) & _
37         "<hotSpot x='20' y='2' xunits='pixels' yunits='pixels'/>" & Chr(10) & _
38         "</IconStyle>" & Chr(10) & _
39         "<ListStyle>" & Chr(10) & _
40         "</ListStyle>" & Chr(10) & _
41         "</Style>" & Chr(10) & _
42         "<Folder>" & Chr(10) & _
43         "<name>临时位置</name>"
44     s = s & "<open>1</open>"
45     SaveFile s, f
46     For i = 2 To Sheet1.UsedRange.Rows.Count
47         s = "<Placemark>" & Chr(10) & "<name>" & Sheet1.Cells(i, 1).Value & "</name>" & Chr(10) & _
48             "<Camera>" & Chr(10) & _
49             "<longitude>" & Sheet1.Cells(i, 2).Value & "</longitude>" & Chr(10) & _
50             "<latitude>" & Sheet1.Cells(i, 3).Value & "</latitude>" & Chr(10) & _
51             "<altitude>500</altitude>" & Chr(10) & _
52             "<heading>0</heading>" & Chr(10) & _
53             "<tilt>0</tilt>" & Chr(10) & _
54             "<altitudeMode>relativeToGround</altitudeMode>" & Chr(10) & _
55             "<gx:altitudeMode>relativeToSeaFloor</gx:altitudeMode>" & Chr(10) & _
56             "</Camera>" & Chr(10) & _
57             "<styleUrl>#msn_ylw-pushpin</styleUrl>" & Chr(10) & _
58             "<Point>" & Chr(10) & _
59             "<altitudeMode>absolute</altitudeMode>" & Chr(10) & _
60             "<gx:altitudeMode>clampToSeaFloor</gx:altitudeMode>" & Chr(10) & _
61             "<coordinates>" & Sheet1.Cells(i, 2).Value & "," & Sheet1.Cells(i, 3).Value & ",0</coordinates>" & Chr(10) & _
62             "</Point>" & Chr(10) & _
63             "</Placemark>" & Chr(10)
64             SaveFile s, f
65     Next
66     s = "</Folder></Document></kml>"
67     SaveFile s, f
68     MsgBox "down"
69 End Sub
70 
71 Sub SaveFile(sql As String, fileName As String)
72 '--------------------------------------------------------------
73 '功    能：保存语句,若已存在文件则直接追加,若文件不存在在先新建.
74 '作    者：erqie
75 '制作日期：2009-08-24
76 '修订日期：
77 'ForReading 1 以只读方式打开文件。 不能写这个文件。
78 'ForWriting 2 以写方式打开文件
79 'ForAppending 8 打开文件并从文件末尾开始写。
80 '--------------------------------------------------------------
81     Dim fso, MyFile
82     Set fso = CreateObject("Scripting.FileSystemObject")
83     If (fso.fileExists(fileName)) Then
84         '参数8表示在文件末尾追加写入
85         Set MyFile = fso.OpenTextFile(fileName, 8)
86         'fso.Delete (fileName)
87         
88     Else
89         'ture表示覆盖创建
90         Set MyFile = fso.CreateTextFile(fileName, ture)
91     End If
92     MyFile.writeline (sql)
93     MyFile.Close
94     Set fso = Nothing
95     Set MyFile = Nothing
96 End Sub

 其中GenPlacemark过程用于生成kml文件主体，基本思路：1.把kml文件的样式设置等固定部分先保存到变量s里（for循环以前），2.循环excel里存储的地标信息，并生成相应的Placemark段，具体位于代码的for循环体里。

SaveFile函数是用来保存文件的。

需要注意的是：1.kml文件坐标生效的地方位于：

"<coordinates>" & Sheet1.Cells(i, 2).Value & "," & Sheet1.Cells(i, 3).Value & ",0</coordinates>"

而不是

"<longitude>" & Sheet1.Cells(i, 2).Value & "</longitude>" & Chr(10) & _
 "<latitude>" & Sheet1.Cells(i, 3).Value & "</latitude>" & Chr(10) & _

2.保存文件函数经过了多次调用，这是因为如果把所有信息都存储到变量s里，最后保存，excel会死掉，所以不得不在中间生成一段代码就保存一次。

3.使用vba保存的文件格式是gb2312的，而google earth只次utf8的编码，所以尽管生成的kml文件头里注明了

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

但实际是不生效的，需要用文本编辑器，如;emeditor、editplus等将生成的文件另存为utf8编码。尝试过把

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

改成

"<?xml version='1.0' encoding='gb2312'?>"

但google earth不认，只好手动转字体编码了。主要是考虑到中文 地标名称，如果不是utf8编码，用google earth打开后会乱码，改完后就OK了。

 使用此脚本步骤：打开保存有地标信息的excel文件，确保第一列为名称、第二列为东经，第三列为北纬，坐标以小数度为单位。按alt+f11调出vba编辑器，把kml脚本粘贴过去，使光标位于genplacemark函数体任意位置，按f5运行。结果默认保存在c盘根目录。由于保存时用的是追加写入的方式，因此每次运行前先删除c盘根目录下以前生面的point.kml文件。

kml脚本