标题代码要求
在空白的表格中,A列为形成一个封闭图形的经纬度合集,每个经度纬度之间都是通过逗号隔开的,B列为计划生成封闭图形的名称,A列和B列没有标题行,计划通过VBA代码,批量生成封闭图形,并保存成谷歌地球可以识别的kml文件,结果保存在D:\polygons.kml中
标题表格填写要求
标题可实现的代码
Option Explicit
Sub GenerateKMLFile()
’ Initialize the KML document
Dim kml As String
kml = “<?xml version=""1.0"" encoding=""UTF-8""?>” & vbCrLf & _
“<kml xmlns=”“http://www.opengis.net/kml/2.2"”>" & vbCrLf & _
“” & vbCrLf & _
“Polygons” & vbCrLf & _
“” & vbCrLf
' Loop through all non-empty cells in column A
Dim lastRow As Long
lastRow = Range("A" & Rows.Count).End(xlUp).Row
Dim cell As Range
For Each cell In Range("A1:A" & lastRow)
If Not IsEmpty(cell.Value) Then
' Split the coordinates into an array
Dim arrCoords() As String
arrCoords = Split(cell.Value, ",")
' Get the name of the polygon from column B
Dim name As String
name = Trim(cell.Offset(0, 1).Value)
' Create the KML for the polygon
Dim polygonKML As String
polygonKML = "<Placemark>" & vbCrLf & _
"<name>" & name & "</name>" & vbCrLf & _
"<Polygon>" & vbCrLf & _
"<outerBoundaryIs>" & vbCrLf & _
"<LinearRing>" & vbCrLf & _
"<coordinates>"
' Add the coordinates to the polygon KML string
Dim i As Long
For i = 0 To UBound(arrCoords) Step 2
If i + 1 <= UBound(arrCoords) Then
polygonKML = polygonKML & arrCoords(i + 1) & "," & arrCoords(i) & ",0" & vbCrLf
End If
Next i
' Close the polygon KML string
polygonKML = polygonKML & "</coordinates>" & vbCrLf & _
"</LinearRing>" & vbCrLf & _
"</outerBoundaryIs>" & vbCrLf & _
"</Polygon>" & vbCrLf & _
"</Placemark>" & vbCrLf
' Add the polygon KML to the main KML document
kml = kml & polygonKML
End If
Next cell
' Close the KML document
kml = kml & "</Folder>" & vbCrLf & _
"</Document>" & vbCrLf & _
"</kml>"
' Save the KML file to disk
Dim filePath As String
filePath = "D:\polygons.kml"
Dim fileNum As Integer
fileNum = FreeFile()
Open filePath For Output As #fileNum
Print #fileNum, kml
Close #fileNum
End Sub