EXCEL里直接生成KML文件

whbtomboy

Sub GenPlacemark()

    Dim i As Integer

    Dim s As String '存储生成的代码

    Dim f As String '保存的文件名

    Dim rng As Range

    f = "c:\point.kml"

    s = "<kml xmlns=""http://earth.google.com/kml/2.0"">" & Chr(13) & _

        "<Folder>"

    Set rng = Intersect(Selection, ActiveSheet.UsedRange)

    If rng Is Nothing Then MsgBox "请选择合适的数据信息!": Exit Sub

    For i = 1 To Selection.Rows.Count

            s = s & "<Placemark><description></description><name>" & rng(i, 1).Value &  _

                    " </name><LookAt>" & _

                    "<longitude>" & rng(i, 2).Value & "</longitude>" & _

                    "<latitude>" & rng(i, 3).Value & "</latitude>" & _

                    "<range>2000</range>" & _

                    "<tilt>0</tilt>" & _

                    "<heading>3</heading>" & _

                    "</LookAt><Point>" & _

                    "<coordinates>" & rng(i, 2).Value & "," & rng(i, 3) & ",0</coordinates>" & _

                    "</Point> </Placemark>" & Chr(13)

    Next

    s = s & Chr(13) & "</Folder></kml>"

    SaveFile s, f ' 件，则中文名可以正常显示

    FileZM f, "GB2312", f, "UTF-8"   '转换成UTF-8编码的文件

    MsgBox "已生成！"

End Sub

Sub SaveFile(sql As String, fileName As String)

    Dim fso, MyFile

    Set fso = CreateObject("Scripting.FileSystemObject")

        Set MyFile = fso.CreateTextFile(fileName, True)

    MyFile.writeline (sql)

    MyFile.Close

    Set fso = Nothing

    Set MyFile = Nothing

End Sub

'vba生成的文件是gb2312编码的,如果站点是汉字，则google不能识别，显示乱码，需要转换成UTF-8的编码，下面的函数是把已生成的GB2312文件转成UTF-8文件

'参数：源文件，源文件编码，目标文件，目标文件编码。编码举例----"gb2312"、"UTF-8"等

Sub FileZM(sFile As String, sCode As String, dFile As String, dCode As String)

Dim ObjStream As Object

Set ObjStream = CreateObject("Adodb.Stream")

With ObjStream

    .Mode = 3         'adModeReadWrite = 3 ' 指示读/写权限。

    .Type = 1         'adTypeBinary = 1

    .Open

    .LoadFromFile sFile   '源文件

    .Position = 0

    .Type = 2         'adTypeText = 2

    .Charset = sCode

    sCode = .ReadText '读取文本到sCode

    .Position = 0     ' 这只是定位到文件头，保留

    .SetEOS           ' 完全重写不要漏了这个,通过使当前 Position 成为流的结尾来更新 EOS 属性的值。当前位置后面的所有字节或字符都将被截断

    .Type = 2         'adTypeText = 2

    .Charset = dCode       '指定输出编码

    .WriteText sCode       '写入指定的文本数据到Adodb.Stream

     .SaveToFile dFile, 2

    .Close

End With

Set ObjStream = Nothing

End Sub

上面的程序的实现都是参考以下资料完成的，这里面设计的知识还是挺多的，涉及到kml文档，文本的写入，编码的转换等，也是费了一番功夫才得以实现，完成之后还是感觉自己欠缺的还是很多，需要学的东西很多，还得继续奋进，把自己工作中经验分享给大家，希望能帮助大家！
资料参考：

1.http://www.cnblogs.com/erqie/archive/2011/06/08/2075579.html

2.http://club.excelhome.net/thread-868093-1-1.html