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