'Creates a Google Earth/Maps "KML" file from a GroundSpeak (geocaching.com) GPX file. 
'The created file is named the same as the source GPX file except for the new KML 
'file extension. The source GPX file is not changed. 
'Released to the Public Domain 2011 by author Eric Phelps http://ericphelps.com. 
'May be used, distributed, and modified with no restrictions. This script comes with 
'no warranty or expectation of usability. Just because it worked once for me on my 
'test files and on my PC does not  mean it will work for you on your PC and with your 
'GPX files.

Option Explicit

Main

Sub Main()
	Dim kml, gpx, fs, ndName, ndDescription, wpt, wpts
	Dim strData, elem, node, xmlerr, strXmlFile, strUrl
	'Create objects
	Set fs = CreateObject("Scripting.FileSystemObject")
	Set kml = NewXmlDocObject()
	Set gpx = NewXmlDocObject()
	
	'Check input	
	If WScript.Arguments.Count <> 1 Then
		MsgBox "Drop a GPX file on the script!"
		Exit Sub
	End If
	If Not fs.FileExists(WScript.Arguments(0)) Then
		MsgBox "The file you dropped:" & vbCrLf & WScript.Arguments(0) & vbCrLf  & "...isn't a file. Drop a GPX file on the script."
		Exit Sub
	End If
	If Lcase(fs.GetExtensionName(WScript.Arguments(0))) <> "gpx" Then
		MsgBox "The file you dropped:" & vbCrLf & WScript.Arguments(0) & vbCrLf  & "...isn't a GPX file. Drop a GPX file on the script."
		Exit Sub
	End If
	
	'Delete any existing output file
	strXmlFile = fs.BuildPath(fs.GetParentFolderName(WScript.Arguments(0)), fs.GetBaseName(WScript.Arguments(0)) & ".kml")
	If fs.FileExists(strXmlFile) Then
		fs.DeleteFile strXmlFile
	End If
	
	'Load the file and verify it is a real GPX file
	gpx.load(WScript.Arguments(0))
	Set node = gpx.selectSingleNode("//gpx/wpt/name")
	If node Is Nothing Then
		'Try loading it another way
		strData = File2String(WScript.Arguments(0))
		strData = ToAscii(strData)
		strData = RemoveHighBytes(strData)
		gpx.loadXML(strData)
		Set node = gpx.selectSingleNode("//gpx/wpt/name")
		If node Is Nothing Then
			MsgBox "I can't locate any named waypoints in the GPX file you dropped. The official XML parser error is:" & vbCrLf & gpx.Validate.reason
			Exit Sub
		End If
	End If
	
	'Create the basic KML header
	kml.appendChild(kml.createProcessingInstruction("xml","version=""1.0"" encoding=""UTF-8"""))
 	Set elem = kml.appendChild(kml.createElement("kml"))
 	elem.SetAttribute "xmlns", "http://www.opengis.net/kml/2.2"
 	kml.selectSingleNode("//kml").appendChild kml.createElement("Document")
 	
 	'Create icon list
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "traditional"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/2.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "multi"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/3.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "virtual"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/4.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "letterbox"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/5.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "event"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/6.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "mystery"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/8.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "reference"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/12.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "parking"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/136.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "earth"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/137.gif"
 	Set elem = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Style"))
 	elem.SetAttribute "id", "wherigo"
 	Set node = elem.appendChild(kml.createElement("IconStyle"))
	Set node = node.appendChild(kml.createElement("Icon"))
	Set node = node.appendChild(kml.createElement("href"))
	node.text = "http://www.geocaching.com/images/WptTypes/1858.gif"
 	
	'Process all the waypoints
	Set wpts = gpx.getElementsByTagName("wpt")
	For Each wpt In wpts
	
		'Create the basic skeleton for a KML placemark
	 	Set node = kml.selectSingleNode("//kml/Document").appendChild(kml.createElement("Placemark"))
	 	node.AppendChild kml.createElement("name")
	 	Set ndName = node.selectSingleNode("name").appendChild(kml.createCDATASection(""))
	 	node.AppendChild kml.createElement("description")
	 	Set ndDescription = node.selectSingleNode("description").appendChild(kml.createCDATASection(""))
	 	node.appendChild kml.createElement("Point")
	 	node.selectSingleNode("Point").appendChild kml.createElement("coordinates")
	 	
	 	'Fill in the KML name with the friendly "urlname"
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("urlname").text
		On Error Goto 0
		If strData <> "" Then
			ndName.AppendData strData
		End If
				
		'Define the icon type -- if we can figure it out!
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("type").text
		On Error Goto 0
		If strData <> "" Then
			Select Case strData
				Case "Geocache|Traditional Cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#traditional"
				Case "Geocache|Benchmark"
					node.appendChild(kml.createElement("styleUrl")).text = "#traditional"
				Case "Geocache|Letterbox Hybrid"
					node.appendChild(kml.createElement("styleUrl")).text = "#letterbox"
				Case "Geocache|Unknown Cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#mystery"
				Case "Waypoint|Stages of a Multicache"
					node.appendChild(kml.createElement("styleUrl")).text = "#multi"
				Case "Geocache|Multi-cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#multi"
				Case "Geocache|Earthcache"
					node.appendChild(kml.createElement("styleUrl")).text = "#earth"
				Case "Geocache|Event Cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#event"
				Case "Geocache|Mega-Event Cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#event"
				Case "Waypoint|Reference Point"
					node.appendChild(kml.createElement("styleUrl")).text = "#reference"
				Case "Waypoint|Parking Area"
					node.appendChild(kml.createElement("styleUrl")).text = "#parking"
				Case "Waypoint|Trailhead"
					node.appendChild(kml.createElement("styleUrl")).text = "#parking"
				Case "Geocache|Wherigo Cache"
					node.appendChild(kml.createElement("styleUrl")).text = "#wherigo"
				Case Else
					'Do nothing and let it show the default icon!
			End Select
		End If

		'Fill in the KML description with just about everything
		strUrl = ""
		On Error Resume Next
		strUrl = wpt.selectSingleNode("url").text
		On Error Goto 0
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("name").text
		On Error Goto 0
		If strData <> "" Then
			If strUrl <> "" Then
				ndDescription.AppendData "<a href=""" & strUrl & """>[Details]</a>"
				ndDescription.AppendData "&nbsp;&nbsp;<a href=""http://www.geocaching.com/seek/log.aspx?wp=" & strData & """>[Log Visit]</a>"
			End If
		End If

		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:type").text
		On Error Goto 0
		If strData <> "" Then
			ndDescription.AppendData "<br/>Type:" & strData
		End If
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:container").text
		On Error Goto 0
		If strData <> "" Then
			ndDescription.AppendData "<br/>Container:" & strData
		End If
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:difficulty").text
		On Error Goto 0
		If strData <> "" Then
			ndDescription.AppendData "<br/>Difficulty:" & strData
		End If
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:terrain").text
		On Error Goto 0
		If strData <> "" Then
			ndDescription.AppendData "<br/>Terrain:" & strData
		End If
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:short_description").text
		On Error Goto 0
		If strData <> "" Then
			strData = Replace(strData, vbCr, " ")
			strData = Replace(strData, vbLf, " ")
			strData = Replace(strData, vbTab, " ")
			Do While Instr(strData, "  ") <> 0 : strData = Replace(strData, "  ", " ") : Loop
			strData = Trim(strData)
			ndDescription.AppendData "<br/>Description: " & strData
		End If

		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:long_description").text
		On Error Goto 0
		If strData <> "" Then
			strData = Replace(strData, vbCr, " ")
			strData = Replace(strData, vbLf, " ")
			strData = Replace(strData, vbTab, " ")
			Do While Instr(strData, "  ") <> 0 : strData = Replace(strData, "  ", " ") : Loop
			strData = Trim(strData)
			ndDescription.AppendData " " & strData
		End If
		
		strData = ""
		On Error Resume Next
		strData = wpt.selectSingleNode("groundspeak:cache/groundspeak:encoded_hints").text
		On Error Goto 0
		If strData <> "" Then
			strData = ROT13(strData) & " [" & strData & "] "
			strData = Replace(strData, vbCr, " ")
			strData = Replace(strData, vbLf, " ")
			strData = Replace(strData, vbTab, " ")
			Do While Instr(strData, "  ") <> 0 : strData = Replace(strData, "  ", " ") : Loop
			strData = Trim(strData)
			ndDescription.AppendData "<br/>Hint: " & strData
		End If
		
		'Add the actual coordinates
		strData = ""
		On Error Resume Next
		strData = wpt.getAttribute("lon")
		On Error Goto 0
		node.selectSingleNode("Point/coordinates").Text = strData
		
		strData = ""
		On Error Resume Next
		strData = wpt.getAttribute("lat")
		On Error Goto 0
		node.selectSingleNode("Point/coordinates").Text = node.selectSingleNode("Point/coordinates").Text & "," & strData
		'node.selectSingleNode("Point/coordinates").Text = node.selectSingleNode("Point/coordinates").Text & "," & 0

	Next
	
	'Save the new KML file
	kml.save strXmlFile

End Sub

Function NewXmlDocObject()
Dim xml
	On Error Resume Next
	Set xml = Nothing
	If xml Is Nothing Then Set xml = CreateObject("Msxml2.DOMDocument.4.0")
	If xml Is Nothing Then Set xml = CreateObject("Msxml2.DOMDocument")
	If xml Is Nothing Then Set xml = CreateObject("Msxml2.XMLDocument")
	If xml Is Nothing Then Set xml = CreateObject("Msxml.DOMDocument")
	If xml Is Nothing Then Set xml = CreateObject("Microsoft.XMLDOM")
	On Error Goto 0
	xml.async = False
	Set NewXmlDocObject = xml
End Function

Function HtmlEncode(strText)
'Because it is NEVER safe to display data that has been influenced by a user.
Dim strBuffer, lngPos
	strBuffer = ""
	If Not IsNull(strText) Then
		If strText <> "" Then
			For lngPos = 1 To Len(strText)
				strBuffer = strBuffer & "&#" & Asc(Mid(strText, lngPos, 1)) & ";"
			Next
		End If
	End If
	HtmlEncode = strBuffer
End Function

Function File2String(strFile) 'As String
Dim fs 'As Scripting.FileSystemObject
Dim ts 'As Scripting.TextStream
Const ForReading = 1
	Set fs = CreateObject("Scripting.FileSystemObject")
	If fs.FileExists(strFile) Then
		Set ts = fs.OpenTextFile(strFile, ForReading, True)
		If ts.AtEndOfStream Then
			File2String =""
		Else
			File2String = ts.ReadAll
		End If
		ts.Close
	Else
		File2String = ""
	End If
End Function

Function RemoveHighBytes(strText)
	Dim lngLength, lngCount, strOut
	strOut = ""
	For lngCount = 1 To Len(strText)
		If Asc(Mid(strText, lngCount, 1)) > 127 Then
			strOut = strOut & " "
		Else
			strOut = strOut & Mid(strText, lngCount, 1)
		End If
	Next
	RemoveHighBytes = strOut
End Function

Function ToAscii(strText)
	'Replaces unusual characters with plain ascii
	Dim strGood, strBad, strContent
	strContent = strText
	strGood = """" : For Each strBad In Split("“ ”") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "--" : For Each strBad In Split("– —") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "ss" : For Each strBad In Split("ß") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "'" : For Each strBad In Split("’ ‘ ` ´") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "A" : For Each strBad In Split("Ä Å À Á Â Ã") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "C" : For Each strBad In Split("Ç") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "E" : For Each strBad In Split("Ë È É Ê") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "I" : For Each strBad In Split("Í Î Ï Ì") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "N" : For Each strBad In Split("Ñ") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "O" : For Each strBad In Split("Ø Ó Ô Õ Ö Ò") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "U" : For Each strBad In Split("Ü Û Ú Ù") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "Y" : For Each strBad In Split("Ý") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "a" : For Each strBad In Split("å ä ã â á à") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "c" : For Each strBad In Split("ç") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "e" : For Each strBad In Split("ë ê é è") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "i" : For Each strBad In Split("ï î í ì") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "n" : For Each strBad In Split("ñ") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "o" : For Each strBad In Split("ø ö õ ô ó ò") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "u" : For Each strBad In Split("ü û ú ù") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "y" : For Each strBad In Split("ÿ ý") : strContent = Replace(strContent, strBad, strGood) : Next
	strGood = "z" : For Each strBad In Split("ž") : strContent = Replace(strContent, strBad, strGood) : Next
	ToAscii = strContent
End Function

Function ROT13(strString) 'As String
'ROT13 substitutes each letter for one that is 13 characters 
'further in the alphabet. "A" becomes "N", "B" becomes "O", 
'and so on. This is a symetrical code (encoding and decoding
'by the same function)
Const DOUBLE_ALPHABET = "abcdefghijklmnopqrstuvwxyzabcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZABCDEFGHIJKLMNOPQRSTUVWXYZ"
Dim strROT13
Dim lngPos
Dim intChar
	For lngPos = 1 To Len(strString)
		intChar = Instr(DOUBLE_ALPHABET, Mid(strString, lngPos, 1))
		If intChar = 0 Then
			strROT13 = strROT13 & Mid(strString, lngPos, 1)
		Else
			strROT13 = strROT13 & Mid(DOUBLE_ALPHABET, intChar + 13, 1)
		End If
	Next
	ROT13 = strROT13
End Function