PDA

View Full Version : [SOLVED:] Parse Excel data to Google Earth Paths (LineString)


Kestrel
09-26-2019, 09:00 PM
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.

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




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
snb
09-27-2019, 12:23 AM
I'd start reducing the code to readable proportions.


Public Sub CreateKML()
sn = Sheets("KML").Range("CoordData")
c00 = Sheets("KML").Range("KMLname")
c01 = Sheets("KML").Range("OutputPath") & "\" & c00 & ".kml"

c02 = Join(Array("<?xml version=""1.0"" encoding=""UTF-8""?>", "<Folder>", "<name>" & c00 & "</name>", "<open>1</open>"), vbCrLf)

For j = 2 To UBound(sn)
Xml = Xml & CreatePlacemark(sn(j, 1), "", sn(j, 2), sn(j, 3))
Xml = Xml & CreateLineString
Loop
Xml = Xml & "</Folder>" & vbCrLf

If Dir(c01) <> "" Then Kill c01

Open c01 For Binary As #1
Put #1, , Xml
Close

Shell "open " & c01
End Sub
Kestrel
09-27-2019, 12:35 AM
Thanks SNB,
I'm quite new to VBA so still trying to get the feel of it all. Will try your suggestion later, have to go to work now ��
Kestrel
09-27-2019, 03:26 AM
Hi SNB,

Tried your code which returned a Compile Error: Variable not defined, for,
Public Sub CreateKML()
sn = Sheets("KML").Range("CoordData")

Regards, Paul
snb
09-27-2019, 05:10 AM
Remove 'option Explicit'
Kestrel
09-27-2019, 06:13 AM
Remove 'option Explicit'

I tried removing Option Explicit from the first line of code, I tried removing the whole section of Option Explicit, still no joy.
Sorry , I just am out of my depth at the moment but keen to be educated on the intricacies of VBA.

Thanks for the interest in my post.
Kestrel
09-28-2019, 09:14 PM
I'm now trying a new approach with some other code I found.
Now I get a Next without For error here on the last print command

Next
Print #1

Any help much appreciated.

Regards Paul



Sub ExportKML()
'Check if there is any data
yA = Sheets("Main").Cells(Rows.Count, 2).End(xlUp).Row
yB = Sheets("Main").Cells(Rows.Count, 3).End(xlUp).Row
If yA <> yB Then
a = MsgBox("Inconsistent Lat and Long data, please check the data and try again", vbCritical)
Exit Sub
End If
If yA < 2 Or yB < 2 Then
a = MsgBox("There is no Lat and Long data, please enter the data and try again", vbCritical)
Exit Sub
End If
sfilename = Application.GetSaveAsFilename(BridgeFIDNo & ".kml", _
"Google Earth files (*.kml),*.kml", 1, "Save *.kml")
If sfilename = False Then
Exit Sub
Else
Sheets("Hidden").Range("A2") = sfilename
End If
Set filepath = Sheets("Hidden").Range("A2")
' Set document name
docName = "KML Document exported from Excel"

Open filepath For Output As #1

'Write header to file
outputText = [Hidden!A4] & docName & [Hidden!A5]
Print #1, outputText

'Get Data and its attributes
'Loop through each data point in column A, get attributes if any and write it out to kml
For j = 2 To yA
Latitude = Sheets("Main").Cells(j, 2)
Longitude = Sheets("Main").Cells(j, 3)
ptName = Sheets("Main").Cells(j, 1)

Print #1, [Hidden!A6] & ptName & [Hidden!A7]
'read no of attributes (max 10 supported)
ncols = Sheets("Main").Cells(j, 15).End(xlToLeft).Column
For k = 4 To ncols
Attrib = Sheets("Main").Cells(j, k)
AttribHeading = Sheets("Main").Cells(1, k)
Print #1, [Hidden!A8] & AttribHeading & [Hidden!A9] & Attrib & [Hidden!A10]


Next
Print #1, [Hidden!A11] & Longitude & "," & Latitude & [Hidden!A12]

Next
Print #1, [Hidden!A14] & Longitude & "," & Latitude & [Hidden!A15]

Next
Print #1, [Hidden!A13]

Close #1
Kestrel
10-10-2019, 07:00 PM
I'm getting a little closer now and learning as I go. I have created a Public Function CreateLineString but still not quite getting the required output in the generated KML file.
The KML file should look like this, generating a linestring between consecutive coordinates.


</Placemark>
<Placemark>
<name>Flight plan</name>
<description>Flight plan from Charter Enquiry</description>
<styleUrl>#yellowLine</styleUrl>
<LineString>
<extrude>0</extrude>
<tessellate>1</tessellate>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>
121.46166666667,-30.7894444444391,0
128.883333333302,-31.7166666666744,0
121.46166666667,-30.7894444444391,0
</coordinates>
</LineString>
</Placemark>[CODE]

Mk KML is generating separate placemark items like this;


[CODE]<Placemark>
<styleUrl>#yellowLine</styleUrl> <LineString>
<extrude>0</extrude>
<tessellate>1</tessellate>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>128.3,-25.05</coordinates>
</LineString>
</Placemark>
<Placemark>
<styleUrl>#yellowLine</styleUrl> <LineString>
<extrude>0</extrude>
<tessellate>1</tessellate>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>120.2206,-26.62917</coordinates>
</LineString>
</Placemark>
<Placemark>
<styleUrl>#yellowLine</styleUrl> <LineString>
<extrude>0</extrude>
<tessellate>1</tessellate>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>121.4617,-30.78944</coordinates>
</LineString>
</Placemark>
<Placemark>
<styleUrl>#yellowLine</styleUrl> <LineString>
<extrude>0</extrude>
<tessellate>1</tessellate>
<altitudeMode>clampToGround</altitudeMode>
<coordinates>120.2206,-26.62917
126.5833,-26.12833</coordinates>
</LineString>
</Placemark>

Any help much appreciated.
Regards, Paul



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(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 & " <styleUrl>#yellowLine</styleUrl>"
Xml = Xml & " <LineString>" & vbCrLf
Xml = Xml & " <extrude>0</extrude>" & vbCrLf
Xml = Xml & " <tessellate>1</tessellate>" & vbCrLf
Xml = Xml & " <altitudeMode>clampToGround</altitudeMode>" & vbCrLf
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)
CreateLineString = 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 LineString As String
Dim Longitude As Double, Latitude As Double
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)
Row = Row + 1
Loop

Row = 2
Do While Arr(Row, 1) <> ""
PlaceName = Arr(Row, 1)
Description = ""
Latitude = Arr(Row, 2)
Longitude = Arr(Row, 3)
Xml = Xml & CreateLineString(PlaceName, Description, Longitude, Latitude)
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
Kestrel
10-12-2019, 02:22 AM
I finally found a solution to the 0.00,0.00 coordinates. The erroneous waypoints are still generated but they now return the start coordinate. An elegant solution, pity it took me so long.

=IF(Quote!E25="",$D$2,IFERROR(CONCATENATE(VLOOKUP(A14,'Place Names'!$A$4:$I$6993,5,TRUE),",",VLOOKUP(A14,'Place Names'!$A$4:$I$6993,4,TRUE)),""))

25262

25263
pardonn13
02-07-2020, 12:51 AM
Hello, Im new in VBA.

May I ask where did you found any sample on making the program VBA to KML. I was able to create a textfile and need to copy and paste it to notepad and then save it as a KML file. I want to redirect save it as a KML and wont go through notepad anymore. Can someone give me a site or a sample or a tutorial so that I can redirect it. Every help is appreciated:yes:yes. Thank you very much:yes:yes.

Best Regards,
Morante, Arjay P.