Consulting

Results 1 to 10 of 10

Thread: Parse Excel data to Google Earth Paths (LineString)

  1. #1
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location

    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.

    Sample.jpg


    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
    Last edited by Kestrel; 09-26-2019 at 09:17 PM. Reason: Added more information about where the error is

  2. #2
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,774
    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

  3. #3
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    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 ��

  4. #4
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    Hi SNB,

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

    Regards, Paul

  5. #5
    Knowledge Base Approver VBAX Guru
    Joined
    Apr 2012
    Posts
    4,774
    Remove 'option Explicit'

  6. #6
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    Quote Originally Posted by snb View Post
    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.

  7. #7
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    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

  8. #8
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    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.

    [CODE]</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;


    <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

  9. #9
    VBAX Regular
    Joined
    Sep 2019
    Posts
    27
    Location
    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)),""))

    finally.jpg

    finally2.jpg
    Last edited by Kestrel; 10-12-2019 at 04:22 AM.

  10. #10
    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. Thank you very much.

    Best Regards,
    Morante, Arjay P.

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •