1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53
| Private Sub GE_Click()
Dim rst As DAO.Recordset
Dim db As DAO.Database
Dim start_path As String
Dim fs As Scripting.FileSystemObject, f As Scripting.TextStream
Const ForReading = 1, ForWriting = 2, ForAppending = 3
Set fs = CreateObject("Scripting.FileSystemObject")
'GEPath = "C:\Program Files\Google\Google Earth Pro\client\googleearth.exe"
Dim URL$, ChromePath$, Wsh
'On lance Google Drive
Set Wsh = CreateObject("wscript.shell")
URL = "https://earth.google.com/"
ChromePath = """C:\Program Files\Google\Chrome\Application\chrome.exe"""
' Shell (ChromePath & " -url " & URL)
'Ouvrir la table LatLong
start_path = CurrentProject.Path & "\" & Me.Annee & "\" & Me.NOAffaire & "\" & "KML" & Me.NOAffaire & ".kml"
'start_path = Replace(start_path, " \ ", "") & “KML.kml”
Set db = CurrentDb
Set rst = db.OpenRecordset("SELECT VuePhoto.Ech,VuePhoto.longitude,VuePhoto.Latitude FROM VuePhoto WHERE VuePhoto.NOInfo=EVAL('Forms.Affaire.NUME');", dbOpenSnapshot)
'Set rst = db.OpenRecordset("LatLong") 'ouvrir la table
' Parcourir les enregistrements
If rst.EOF Or rst.BOF = True Then
MsgBox "Aucune donnée"
rst.Close
Set rst = Nothing
Exit Sub
End If
rst.MoveFirst
Set f = fs.OpenTextFile(start_path, 2, True)
' Ecrire dans le fichier
f.Write "<kml xmlns=" & Chr(34) & "http://earth.google.com/kml/2.0" & Chr(34) & " > " & vbCrLf
f.Write "<Document>" & vbCrLf
Do While Not rst.EOF
f.Write " <Placemark><name>" & rst!Ech & "</name><Point><coordinates>" & rst!Longitude & "," & rst!Latitude & "</coordinates></Point></Placemark>" & vbCrLf
rst.MoveNext
Loop
' Fin du document KML
f.Write "</Document></kml>" & vbCrLf
' Nettoyage
rst.Close
Set rst = Nothing
f.Close
Shell (ChromePath & " -url " & URL & " " & start_path)
'Shell (GEPath & " " & start_path)
End Sub |
Partager