SUB TEST()
Dim i As Integer
Dim s As String '存储生成的代码
Dim f As String '保存的文件名
Dim rng As Range
f = ThisWorkbook.Path & "\GZ.kml"
s = "<kml xmlns=""http://earth.google.com/kml/2.0"">" & Chr(13) & _
"<Folder>"
'Set rng = Intersect(Selection, ActiveSheet.UsedRange)
x = Application.CountA(Worksheets("结果").Range("A:A"))
Set rng = Worksheets("结果").[A1].CurrentRegion
If rng Is Nothing Then MsgBox "请选择合适的数据信息!": Exit Sub
For i = 1 To x
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
VBA生成KML文件
最新推荐文章于 2022-10-30 21:51:15 发布