Wow, that's a lot cleaner Pike. Many thanks for your hep with this, I'm learning a lot.
However I still get the Save *.kml dialogue when clicking the command button.
I did have some other VBA which opened Google Earth on click.
Can the Save As code be Open Application?
filepath = Application.GetSaveAsFilename(".kml", "Google Earth files (*.kml),*.kml", 1, "Save As *.kml")it can try,,,
Option Explicit
Sub ExportKML()
Dim filepath
Dim lngRow As Long, xRow As Long
Dim openinGE As String, GE_exe_Loc, GE_exe
Const docname As String = "Charter Quote"
filepath = Sheets("Hidden").Range("A2")
If filepath = vbNullString Then filepath = "C:\xyz"
If Dir(filepath, vbDirectory) = vbNullString Then
filepath = Application.GetSaveAsFilename(docname & ".kml", "Google Earth files (*.kml),*.kml", 1, "Save As *.kml")
If filepath <> False Then
Sheets("Hidden").Range("A2") = filepath
Else
Exit Sub
End If
End If
With Sheets("Main")
lngRow = 14 - .Evaluate("CountBlank(A1:A14)")
End With
'Debug.Print lngRow
If lngRow < 2 Then Exit Sub
Open filepath For Output As #1
Print #1, "<kml xmlns=" & Chr(34) & "http://www.opengis.net/kml/2.2" & Chr(34) & ">"
Print #1, "<Document><Style id=" & Chr(34) & "yellowLine" & Chr(34) & ">"
Print #1, "<LineStyle>" & Chr(13) & Chr(10) & "<color>7f00ffff</color>" & Chr(13) & Chr(10) & "<width>4</width>"
Print #1, "</LineStyle>" & Chr(13) & Chr(10) & "</Style><name>" & Chr(34) & docname & Chr(34) & "</name> "
For xRow = 2 To lngRow
Print #1, "<Data name=" & Chr(34) & Chr(34) & ">" & Chr(13) & Chr(10) & "<value>"
Print #1, "</value>" & Chr(13) & Chr(10) & "</Data>"
Print #1, "<Placemark>" & Chr(13) & Chr(10) & "<name>"
Print #1, Sheets("Main").Range("A" & xRow).Value
Print #1, "</name>"
Print #1, "<Point>" & Chr(13) & Chr(10) & "<coordinates>"
Print #1, Sheets("Main").Range("D" & xRow).Value
Print #1, "</coordinates>" & Chr(13) & Chr(10) & "</Point>" & Chr(13) & Chr(10) & "<Style id=" & Chr(34) & "a" & Chr(34) & ">"
Print #1, "<IconStyle>" & Chr(13) & Chr(10) & "<Icon>" & Chr(13) & Chr(10) & "<href>http://maps.google.com/mapfiles/kml/pushpin/ylw-pushpin.png</href>"
Print #1, "</Icon>" & Chr(13) & Chr(10) & "</IconStyle>" & Chr(13) & Chr(10) & "</Style>" & Chr(13) & Chr(10) & "<styleUrl>#a</styleUrl>" & Chr(13) & Chr(10) & "</Placemark>"
Next
Print #1, "<Placemark>" & Chr(13) & Chr(10) & "<name>Flight plan</name>" & Chr(13) & Chr(10) & "<description>Flight plan from Charter Enquiry</description>"
Print #1, "<styleUrl>#yellowLine</styleUrl>" & Chr(13) & Chr(10) & "<LineString>" & Chr(13) & Chr(10) & "<extrude>0</extrude>" & Chr(13) & Chr(10) & "<tessellate>1</tessellate>"
Print #1, "<altitudeMode>clampToGround</altitudeMode>" & Chr(13) & Chr(10) & "<coordinates>"
For xRow = 2 To lngRow
Print #1, Sheets("Main").Range("D" & xRow).Value
Next
Print #1, "</coordinates>" & Chr(13) & Chr(10) & "</LineString>" & Chr(13) & Chr(10) & "</Placemark>"
Print #1, "</Document>" & Chr(13) & Chr(10) & "</kml>"
Close #1
If Not Dir("C:\Program Files\Google\Google Earth Pro\googleearth.exe", vbDirectory) = vbNullString Then
Shell "C:\Program Files\Google\Google Earth Pro\googleearth.exe" & " " & Chr(34) & filepath & Chr(34), vbMaximizedFocus
ElseIf Not Dir("C:\Program Files (x86)\Google\Google Earth Pro\googleearth.exe", vbDirectory) = vbNullString Then
Shell "C:\Program Files (x86)\Google\Google Earth Pro\googleearth.exe" & " " & Chr(34) & filepath & Chr(34), vbMaximizedFocus
Else
GE_exe_Loc = Sheets("Hidden").Range("A1").Value
If GE_exe_Loc = vbNullString Then GE_exe_Loc = "C:\xyz"
If Not Dir(GE_exe_Loc, vbDirectory) = vbNullString Then
Shell Chr(34) & GE_exe_Loc & Chr(34) & " " & Chr(34) & filepath & Chr(34), vbMaximizedFocus
Else
GE_exe = MsgBox("Could not locate Google Earth executable, Locate manually?", vbOKCancel + vbCritical, "Google Earth exe")
If GE_exe = vbCancel Then
Exit Sub
Else
GE_exe_Loc = Application.GetSaveAsFilename("googleearth.exe", "googleearth (*.exe),*.exe", 1, "Find *.exe")
Sheets("Hidden").Range("A1").Value = GE_exe_Loc
If GE_exe_Loc <> False Then
If Not Dir(GE_exe_Loc, vbDirectory) = vbNullString Then
Shell Chr(34) & GE_exe_Loc & Chr(34) & " " & Chr(34) & filepath & Chr(34), vbMaximizedFocus
Else
MsgBox "Google Earth does not exist"
End If
End If
End If
End If
End If
End SubTHANK YOU PIKE!!!
You have nailed it.
It worked flawlessly.
I then changed the "Hidden" A2 cell to C:\Windows\Temp\Charter Quote.kml which opened a Save As dialog but once saved, it now overwrites the file and automatically launches Google Earth with the kml file when the command button is clicked.
Bravo, I will be donating $50 to your nominated charity.
Thanks from the RSPCA and thank you for posting
Good morning.
Could you attach the file with the complete macro?
Thank you
Don’t have an account yet? Register yourself now and be a part of our community!