1 Attachment(s)
Parse Excel data to Google Earth Paths (LineString)
Hi All,
I am so close...
I have some VBA code which pulls Latitude and Longitude data and writes a KML file which then opens Google Earth and displays place marks.
I would like to add Paths or LineStrings but keep coming up with compile errors.
The "Public Function CreatePlacemark" section works just fine. This was existing code which I found on the internet, sample screenshot attached.
Attachment 25163
The "Public Function CreateLineString" is code i tried to add which results in a "Argument not Optional" error in "Public Sub CreateKML()"
Regards Paul
Code:
Option Explicit
Public Declare Function ShellExecute _
Lib "shell32.dll" _
Alias "ShellExecuteA" ( _
ByVal hwnd As Long, _
ByVal lpOperation As String, _
ByVal lpFile As String, _
ByVal lpParameters As String, _
ByVal lpDirectory As String, _
ByVal nShowCmd As Long) _
As Long
Private Function CleanString(DirtyString As String) As String
Dim Str As String
Dim i As Long
Dim c As String
Dim b As Long
Str = DirtyString
For i = 1 To Len(Str)
c = Mid(Str, i, 1)
b = Asc(c)
Select Case b
Case 32, 65 To 90, 97 To 122
Case Else
Str = Replace(Str, c, " ")
End Select
Next i
Str = Replace(Str, " ", " ")
Str = Replace(Str, " ", " ")
Str = Replace(Str, " ", " ")
CleanString = Str
End Function
Public Function CreatePlacemark(PlaceName As String, Description As String, Longitude As Double, Latitude As Double) As String
Dim Xml As String
Xml = ""
Xml = Xml & " <Placemark>" & vbCrLf
Xml = Xml & " <description>{DESCRIPTION}</description>" & vbCrLf
Xml = Xml & " <name>{PLACE_NAME}</name>" & vbCrLf
Xml = Xml & " <View>" & vbCrLf
Xml = Xml & " <longitude>{LONGITUDE}</longitude>" & vbCrLf
Xml = Xml & " <latitude>{LATITUDE}</latitude>" & vbCrLf
Xml = Xml & " <range>{RANGE}</range>" & vbCrLf
Xml = Xml & " <tilt>{TILT}</tilt>" & vbCrLf
Xml = Xml & " <heading>{HEADING}</heading>" & vbCrLf
Xml = Xml & " </View>" & vbCrLf
Xml = Xml & " <visibility>1</visibility>" & vbCrLf
Xml = Xml & " <styleUrl>root://styleMaps#default?iconId=0x307</styleUrl>" & vbCrLf
Xml = Xml & " <Style>" & vbCrLf
Xml = Xml & " <icon></icon>" & vbCrLf
Xml = Xml & " </Style>" & vbCrLf
Xml = Xml & " <Point>" & vbCrLf
Xml = Xml & " <coordinates>{LONGITUDE},{LATITUDE}</coordinates>" & vbCrLf
Xml = Xml & " </Point>" & vbCrLf
Xml = Xml & " </Placemark>" & vbCrLf
Xml = Replace(Xml, "{PLACE_NAME}", CleanString(PlaceName))
Xml = Replace(Xml, "{DESCRIPTION}", CleanString(Description))
Xml = Replace(Xml, "{LONGITUDE}", Longitude)
Xml = Replace(Xml, "{LATITUDE}", Latitude)
Xml = Replace(Xml, "{RANGE}", 141.4)
Xml = Replace(Xml, "{TILT}", 0)
Xml = Replace(Xml, "{HEADING}", 0)
CreatePlacemark = Xml
End Function
Public Function CreateLineString(LineString As String, PlaceName As String, Description As String, Longitude As Double, Latitude As Double) As String
Dim Xml As String
Xml = ""
Xml = Xml & " <Placemark>" & vbCrLf
Xml = Xml & "<name>Flight plan</name>"
Xml = Xml & " <description>Flight plan from Champagne PC Services Flight Planner 3000</description>"
Xml = Xml & " <styleUrl>#yellowLine</styleUrl>"
Xml = Xml & " < Linestring > "
Xml = Xml & " <extrude>0</extrude>"
Xml = Xml & " <tessellate>1</tessellate>"
Xml = Xml & " <altitudeMode>clampToGround</altitudeMode>"
Xml = Xml & " <coordinates>"
Xml = Xml & " <coordinates>{LONGITUDE},{LATITUDE}</coordinates>" & vbCrLf
Xml = Xml & " </Linestring>" & vbCrLf
Xml = Xml & " </Placemark>" & vbCrLf
Xml = Replace(Xml, "{PLACE_NAME}", CleanString(PlaceName))
Xml = Replace(Xml, "{DESCRIPTION}", CleanString(Description))
Xml = Replace(Xml, "{LONGITUDE}", Longitude)
Xml = Replace(Xml, "{LATITUDE}", Latitude)
Xml = Replace(Xml, "{RANGE}", 141.4)
Xml = Replace(Xml, "{TILT}", 0)
Xml = Replace(Xml, "{HEADING}", 0)
CreateStringline = Xml
End Function
Public Sub CreateKML()
Dim OutputPath As String, Filename As String
Dim KMLName As String
Dim PlaceName As String, Description As String
Dim Longitude As Double, Latitude As Double
Dim LineString As String
Dim Xml As String
Dim Sht As Excel.Worksheet
Dim Rng As Excel.Range
Dim Row As Long
Dim Arr As Variant
Dim f As Long
Set Sht = ThisWorkbook.Worksheets("KML")
Set Rng = Sht.Range("CoordData")
OutputPath = Sht.Range("OutputPath").Value
KMLName = Sht.Range("KMLName").Value
Arr = Rng.Value
Row = 2
Xml = ""
Xml = Xml & "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf
Xml = Xml & "<Folder>" & vbCrLf
Xml = Xml & " <name>{FOLDER_NAME}</name>" & vbCrLf
Xml = Xml & " <open>1</open>" & vbCrLf
Xml = Replace(Xml, "{FOLDER_NAME}", KMLName)
Do While Arr(Row, 1) <> ""
PlaceName = Arr(Row, 1)
Description = ""
Latitude = Arr(Row, 2)
Longitude = Arr(Row, 3)
Xml = Xml & CreatePlacemark(PlaceName, Description, Longitude, Latitude)
Xml = Xml & CreateLineString
Row = Row + 1
Loop
Xml = Xml & "</Folder>" & vbCrLf
Filename = OutputPath & "\" & KMLName & ".kml"
On Error Resume Next
Kill Filename
On Error GoTo 0
f = FreeFile
Open Filename For Binary As #f
Put #f, , Xml
Close #f
LaunchAssociatedFile Filename
End Sub
Public Function RangeAddress(Row1 As Long, Col1 As Long, Row2 As Long, Col2 As Long) As String
RangeAddress = CellAddress(Row1, Col1) & ":" & CellAddress(Row2, Col2)
End Function
Public Function CellAddress(Row As Long, Col As Long) As String
Dim ColBlock As Long
Dim ColChar As Long
Dim txt As String
ColBlock = Int((Col - 1) / 26)
ColChar = (Col - 1) Mod 26 + 1
If ColBlock > 0 Then
txt = Chr$(64 + ColBlock)
End If
txt = txt & Chr$(64 + ColChar)
CellAddress = txt & Row
End Function
Sub LaunchAssociatedFile(Filename As String)
Dim strAction As String
Dim lngErr As Long
strAction = "OPEN" ' action might be OPEN, NEW or other, depending on what you need to do
lngErr = ShellExecute(0, strAction, Filename, "", "", 0)
End Sub
