Petit code sans prétention montrant par une utilisation très simple le controle de GoogleEarth via ses API.
Deux petits exemples pour charger des données KML soit via la fonction LoadKmlData ou OpenKMLFile. Deux de déplacement et récupération de coordonnées. Et deux exemple de sélection de feature. Enfin deux "Bidouilles" pour sauver un fichier KML à partir d'un feature ou supprimer un feature.
Le Zip contient uniquement le fichier KML Exemple.
Pour les Grand débutant : pour que la source fonctionne ne pas oublié de rajouter dans Projet / Références / "Earth 1.0 type library" Voir copie écran.
Source / Exemple :
'A mettre dans une Feuille avec 8 boutons
Option explicit
'Exemple de chargement de données KML dans googleEarth
Private Sub Command1_Click()
Dim GEI As ApplicationGE
Dim Fichier As String
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
Fichier = App.Path & "\Genève.kml"
Call GEI.OpenKmlFile(Fichier, 1) ' 1= pas de message dans GoogleEarth si le fichier n'existe pas par exemple
End Sub
Private Sub Command2_Click()
Dim GEI As ApplicationGE
Dim KMLData As String
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
'Initialisation données KML
KMLData = "<?xml version=""1.0"" encoding=""UTF-8""?>" & _
"<kml xmlns=""http://earth.google.com/kml/2.1"">" & _
"<Placemark>" & _
"<name>Geneva</name>" & _
"<LookAt>" & _
"<longitude>6.156182706892176</longitude>" & _
"<latitude>46.20746317320977</latitude>" & _
"<altitude>0</altitude>" & _
"<range>316.3662914479763</range>" & _
"<tilt>0</tilt>" & _
"<heading>6.199453434125936</heading>" & _
"</LookAt>" & _
"<Point>" & _
"<coordinates>6.156019183879536,46.20743386584116,0</coordinates>" & _
"</Point>" & _
"</Placemark>" & _
"</kml>"
'Chargement données dans GE
GEI.LoadKmlData KMLData
End Sub
'Exemple de récupération de coordonnées de point et d'altitude
Private Sub Command3_Click()
Dim GEI As ApplicationGE
Dim PointOnTerrain() As Double
Dim PositionCherché(2) As Double
Dim Repeat As Integer
Dim Epsilon As Double
Dim LongDiff As Double
Dim LatDiff As Double
'Initialisation
Epsilon = 0.0005
'Coordonnées du mont Blanc
PositionCherché(0) = 45.8325541
PositionCherché(1) = 6.86437217
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
'Fixe le mode Elevation à 1 ( Activation relief)
GEI.ElevationExaggeration = 1 'Si différent de 0, alors coords[2] est fixée à la vraie altitude du terrain.
'Récupération de données de point centre écran les
Do
'Positionne la caméra sur le Mont Blanc (La vitesse est fixé à 5 = Maxi donc pas d'effet de transition
Call GEI.SetCameraParams(PositionCherché(0), PositionCherché(1), 0, RelativeToGroundAltitudeGE, 100, 0, 0, 5)
PointOnTerrain = GEI.GetPointOnTerrainFromScreenCoords(0, 0)
'Attente que le processus de striming soit terminé sur la zone concerné
While (GEI.StreamingProgressPercentage < 100)
DoEvents
Wend
LongDiff = Abs(PositionCherché(1) - PointOnTerrain(1))
LatDiff = Abs(PositionCherché(0) - PointOnTerrain(0))
Repeat = Repeat + 1
'Controle que la position est bien celle demandée. Repeeat permet déviter de blocquer la procédure
'avec une limite à 100 itérations
Loop While (LongDiff > Epsilon Or LatDiff > Epsilon Or PointOnTerrain(2) < 0) And Repeat < 100
MsgBox "Altitude Mont Blanc dans GoogleEarth " & PointOnTerrain(2)
End Sub
'Affiche la position courante d'un repère présent dans GE
Private Sub Command4_Click()
Dim GEI As ApplicationGE
Dim Feat As FeatureGE
Dim Child As FeatureCollectionGE
Dim CameraInfo As CameraInfoGE
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
' Charge la position default. Cette fonction permet de récupérer les infos en donnant le nom du repère
Set Feat = GEI.GetFeatureByName("default")
'Set Child = Feat.GetChildren
'Debug.Print Child.Count
'Si elle a une vue on y va
If Feat.HasView Then
Call GEI.SetFeatureView(Feat, 5)
End If
'Retourne la position courant
Set CameraInfo = GEI.GetCamera(1)
MsgBox "Latitude=" & CameraInfo.FocusPointLatitude & " Longitude=" & CameraInfo.FocusPointLongitude
End Sub
'fonction pour récupérér un feature GE depuis la base de données primaire
Private Sub Command5_Click()
Dim Indice As Long
Dim GEI As ApplicationGE
Dim Feat As FeatureGE
Dim Child As FeatureCollectionGE
Dim CameraInfo As CameraInfoGE
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
'Racine du layersdatabase
'Récupère les enfants
Set Child = GEI.GetLayersDatabases.Item(1).GetChildren
For Indice = 1 To Child.Count
'Si elle a une vue et si c'est bien ce qui m'intéresse on y va
If Child.Item(Indice).HasView And InStr(Child.Item(Indice).Name, "Élection présidentielle France 2007") Then
Call GEI.SetFeatureView(Child.Item(Indice), 5)
End If
Next Indice
End Sub
'fonction pour récupérer un feature GE depuis son nom
Private Sub Command6_Click()
Dim Indice As Long
Dim GEI As ApplicationGE
Dim Feat As FeatureGE
Dim Child As FeatureCollectionGE
Dim CameraInfo As CameraInfoGE
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
'Récupère les enfants du feature "Geneva" selon exemple
Set Feat = GEI.GetFeatureByName("Geneva")
Call Feat.Highlight
Call GEI.SetFeatureView(Feat, 5)
Set Child = Feat.GetChildren
For Indice = 1 To Child.Count
'Si elle a une vue et si c'est bien ce qui m'intéresse on y va
Debug.Print Child.Item(Indice).Name
'Rend visible le Feature
Child.Item(Indice).Visibility = True
' Se déplace sur le feature
Call GEI.SetFeatureView(Child.Item(Indice), 1)
Call Sleep(1000)
'Attente que le processus de striming soit terminé sur la zone concerné
While (GEI.StreamingProgressPercentage < 100)
DoEvents
Wend
Call Child.Item(Indice).Highlight
Next Indice
End Sub
'Fonction pour sauver le feature sous un format KML
Private Sub Command7_Click()
SauverFeature "Geneva", "C:\tmp\test"
End Sub
Private Sub Command8_Click()
DeleteFeature "Geneva"
End Sub
'------------------------------------------------
' CODE A RAJOUTER DANS UN MODULE
'------------------------------------------------
Option Explicit
Const HWND_TOPMOST = -1&
Const HWND_NOTOPMOST = -2&
Const HWND_TOP = 0
Const SWP_NOSIZE = &H1&
Const SWP_NOMOVE = &H2&
Const SWP_NOACTIVATE = &H10&
Const SWP_SHOWWINDOW = &H40&
Const THREAD_BASE_PRIORITY_MAX = 2
Const HIGH_PRIORITY_CLASS = &H80
Declare Sub SetWindowPos Lib "User32" (ByVal hwnd As Long, ByVal hWndInsertAfter As Long, ByVal X As Long, ByVal Y As Long, ByVal cx As Long, ByVal cy As Long, ByVal wFlags As Long)
'Declaration fonction sleep
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)
Private Declare Function IsWindow Lib "user32.dll" (ByVal hwnd As Long) As Long
Private Declare Function MapVirtualKey Lib "user32.dll" Alias "MapVirtualKeyA" (ByVal wCode As Long, ByVal wMapType As Long) As Long
Private Declare Function GetKeyboardState Lib "user32.dll" (ByRef pbKeyState As Byte) As Long
Private Declare Function SetKeyboardState Lib "user32.dll" (ByRef lppbKeyState As Byte) As Long
Private Declare Function PostMessage Lib "user32.dll" Alias "PostMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Private Declare Function FindWindow Lib "user32.dll" Alias "FindWindowA" (ByVal lpClassName As String, ByVal lpWindowName As String) As Long
'Private Declare Function GetWindow Lib "user32.dll" (ByVal hwnd As Long, ByVal wCmd As Long) As Long
Private Declare Function AttachThreadInput Lib "user32.dll" (ByVal idAttach As Long, ByVal idAttachTo As Long, ByVal fAttach As Long) As Long
Private Declare Function GetCurrentThreadId Lib "kernel32.dll" () As Long
Private Declare Function GetWindowThreadProcessId Lib "user32.dll" (ByVal hwnd As Long, ByRef lpdwProcessId As Long) As Long
Private Const GW_CHILD As Long = 5
Private Const WM_KEYDOWN As Long = &H100
Private Const WM_KEYUP As Long = &H101
Private Const WM_SYSKEYDOWN As Long = &H104
Private Const WM_SYSKEYUP As Long = &H105
' Fonction venant à l'origine de www.vbfrance.com
' http://www.vbfrance.com/codes/SENDKEYSEX-SIMULER-TOUCHE-DANS-FENETRE-PRECISE_41974.aspx
' par Renfield
Public Sub SendKeysEx(ByVal vhTargetWnd As Long, ByVal veKey As VBRUN.KeyCodeConstants, Optional ByVal veShift As VBRUN.ShiftConstants, Optional ByVal vbExtendedKey As Boolean = False)
Dim xbMemBuffer(255) As Byte
Dim xbNewBuffer(255) As Byte
Dim nKeyParam As Long
Dim nTargetThreadID As Long
'# Si la cible est valide...
If IsWindow(vhTargetWnd) Then
nTargetThreadID = GetWindowThreadProcessId(vhTargetWnd, ByVal 0&)
AttachThreadInput GetCurrentThreadId, nTargetThreadID, 1&
nKeyParam = MapVirtualKey(veKey, 0) * &H10000
If vbExtendedKey Then
nKeyParam = nKeyParam Or &H1000000 '# bit 24
End If
'# On mémorise l'etat du clavier
GetKeyboardState xbMemBuffer(0)
If (veShift And vbShiftMask) <> 0 Then
xbNewBuffer(vbKeyShift) = &H80
End If
If (veShift And vbCtrlMask) <> 0 Then
xbNewBuffer(vbKeyControl) = &H80
End If
'# On place notre image du clavier en mémoire
SetKeyboardState xbNewBuffer(0)
'# On prévient la cible que le clavier a été manipulé
PostMessage vhTargetWnd, WM_KEYDOWN, veKey, nKeyParam
PostMessage vhTargetWnd, WM_KEYUP, veKey, nKeyParam Or &HC0000000
'# On 'force' la cible a prendre en compte les changements effectués
Sleep 1
'# Il ne nous reste plus alors qu'a restaurer l'image du clavier.
SetKeyboardState xbMemBuffer(0)
AttachThreadInput GetCurrentThreadId, nTargetThreadID, 0&
End If
End Sub
'-------------------------------------------------------------------------------------------------------------
'Fonction permetant de sauver un feature dans un Fichier KML
'Ce fichier étant un format Ascii, il sera par la suite facile de le traiter pour récupérer les informations
'Seul moyen trouvé pour le moment pour avoir accès aux informations.
'
' Retourne 1 si Feature trouvé et sauvegardé 0 dans le cas contraire
'
' Note la fonction utilise sendkeys et donc elle est dépendante de la langue (CTL+S, ALT+E etc ..)
'
' Pour le moment j'ai rien trouvé de mieux désolé.
'-------------------------------------------------------------------------------------------------------------
Function SauverFeature(NomDuFeature As String, Optional Fichier As String) As Long
Dim Indice As Long
Dim GEI As ApplicationGE
Dim Feat As FeatureGE
Dim Child As FeatureCollectionGE
Dim CameraInfo As CameraInfoGE
Dim retval As Long ' return value
Dim hwnd As Long
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
hwnd = GEI.GetMainHwnd
Sleep 1000
'Récupère un feature par son nom
Set Feat = GEI.GetFeatureByName(NomDuFeature)
'Si le feature à été trouvé
If Feat Is Nothing Then
SauverFeature = 0
Else
'Sélectionne le Feature
Call Feat.Highlight
'# Ctrl + S
'SendKeys "^s"
SendKeysEx hwnd, vbKeyS, vbCtrlMask
'Normalement là on ouvre une autre fenetre donc utilise sendkeys car sinon il faut récupérer le handle
'Rajoute extension .kml si pas présente
If Len(Fichier) Then
Debug.Print InStr(Len(Fichier) - 4, Fichier, ".kml")
If InStr(Len(Fichier) - 4, Fichier, ".kml") = 0 Then
Fichier = Fichier & ".kml"
End If
SendKeys Fichier
End If
'Alt+E
SendKeys "%(E)"
'au cas ou le fichier existe déjà enter
SendKeys "{ENTER}"
' Se déplace sur le feature
Call GEI.SetFeatureView(Feat, 5)
SauverFeature = 1
End If
End Function
Function DeleteFeature(NomDuFeature As String) As Long
Dim Indice As Long
Dim GEI As ApplicationGE
Dim Feat As FeatureGE
Dim Child As FeatureCollectionGE
Dim CameraInfo As CameraInfoGE
Dim hwnd As Long
Set GEI = CreateObject("GoogleEarth.ApplicationGE")
'Attente que GoogleEarth soit initialisé
While (GEI.IsInitialized = 0)
DoEvents
Wend
'Handle de la fenêtre
hwnd = GEI.GetMainHwnd
Sleep 1000
'Récupère un feature par son nom
Set Feat = GEI.GetFeatureByName(NomDuFeature)
'Si le feature à été trouvé
If Feat Is Nothing Then
MsgBox "Rien a supprimer"
DeleteFeature = 0
Else
'Sélectionne le Feature
Call Feat.Highlight
' DELETE
' SendKeys "{DELETE}"
SendKeysEx hwnd, vbKeyDelete
' Valid
SendKeys "{ENTER}"
DeleteFeature = 1
End If
End Function
Conclusion :
Descriptif API GoogleEarth (en anglais)
http://earth.google.com/comapi/interfaceIApplicationGE.html
Comme indiqué sur le site de GoogleEarth cette API est pour le moment au stade BETA. J'espère qu'elle évoluera avec le temps. Les méthodes de récupération d'information étant plus que limitées pour le moment.
Vous n'êtes pas encore membre ?
inscrivez-vous, c'est gratuit et ça prend moins d'une minute !
Les membres obtiennent plus de réponses que les utilisateurs anonymes.
Le fait d'être membre vous permet d'avoir un suivi détaillé de vos demandes et codes sources.
Le fait d'être membre vous permet d'avoir des options supplémentaires.