据一哥们需求，要把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
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) & _
"<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文件。
