PILOTER GOOGLEEARTH AVEC SES API

'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