Convertir fichier excel en fichier kml [Fermé]

Signaler
Messages postés
2
Date d'inscription
samedi 16 février 2013
Statut
Membre
Dernière intervention
17 février 2013
-
 IngenieurEE -
Bonjour,
Je suis novice en VBA et je dois faire un fichier kml pour une application dans google earth à partir d'un fichier excel. Pour ce faire, j'ai créé une interface graphique avec un bouton qui me permette d'enregistrer le fichier kml à un endroit choisi. Cependant j'ai pas trouvé un code pour convertir un fichier excel en un fichier kml , c'est pour cette raison que j'en appelle à votre savoir, peut être pourrez-vous me dépaner, merci d'avance!

6 réponses

Messages postés
23989
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
8 avril 2021
6 719
Bonjour,

Je ne dirais pas impossible vu qu'un fichier kml n'est autre qu'un fichier texte.

Encore faut-il savoir quoi y mettre dedans, donc un travail préparatoire important.
Ici tu trouves une description et la syntaxe des fichiers kml : https://developers.google.com/maps/documentation/javascript/kmllayer?hl=fr
Mais ça m'étonnerait qu'en cherchant un peu plus sur le net tu ne trouves pas un fichier déjà réalisé qui fait ça.
Sur le forum google par exemple : https://productforums.google.com/forum/#!searchin/gec/excel
Le tien a la particularité d'afficher un tableau dans la description. Mais pour quelqu'un habitué à faire des pages html ça ne devrait pas poser de trop grandes difficultés (?)

Et plutôt que de créer un fichier kml peut-être peux-tu utiliser directement les API de google hearth : https://cloud.google.com/maps-platform/?hl=fr
Mais je pense qu'il y a une limitation en nombre de données envoyées ou en nombre de requêtes en un certain temps, à voir.

Pour motiver les intervenants tu devrais déposer un fichier xls de 3-4 points et le fichier kml correspondant.

eric

edit : https://accounts.google.com/ServiceLogin?passive=1209600&continue=https://sites.google.com/site/tekgergedan/home/xls2kml&followup=https://sites.google.com/site/tekgergedan/home/xls2kml

Jamais tu ne répondras à un mp non sollicité...
Bon, ça c'est fait.
5
Merci

Quelques mots de remerciements seront grandement appréciés. Ajouter un commentaire

CCM 65492 internautes nous ont dit merci ce mois-ci

Messages postés
8700
Date d'inscription
dimanche 8 avril 2007
Statut
Contributeur
Dernière intervention
22 janvier 2020
1 152
Bonjour,
A ma connaissance --> c'est impossible
C'est pour réaliser quoi ?
A+

Messages postés
2
Date d'inscription
samedi 16 février 2013
Statut
Membre
Dernière intervention
17 février 2013

bonjour, c'est pour realiser un outil de suivi qui permet de suivre la performance du réseau à travers les KPIs (indicateurs clé de performance) qui sont les informations trouvé le fichier excel
c'est a dire j'ai un fichier excel ou chaque ligne represente une station et les informations sur cette station (non , coordonnées.......) et a partir de ce fichier je dois avoir un autre fichier mais en mode geographique avec google earth par exemple et google earth ne lire que les fichiers kml donc je vais convertir ce fichier excel en un fichier kml et l'ouvrir avec google earth!!
voici 2 figures qui expliquent!!
la 1er represente un exemple de fichier excel
http://www.hostingpics.net/viewer.php?id=154731Sanstitre.jpg
la 2eme represente un exemple de representation de fichier kml sur google earth
http://www.hostingpics.net/viewer.php?id=617527Capture.jpg
Messages postés
23989
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
8 avril 2021
6 719
de rien...
Bonjour;

Code à mettre dans 1 module pour generer KML à partir d'excel:
OPTION EXPLICIT 

'************************************************************************************************************* 
'************************************************************************************************************* 
'DECLARATION DE VARIABLES ET DES CONSTANTES 
'************************************************************************************************************* 
'************************************************************************************************************* 

Public folders As New Collection 
Const FIRSTDATAROW = 13  'premiere ligne active 
Const LATITUDECOL = 26  'colonne latitude 
Const LONGITUDECOL = 27 'colonne longitude 
Const MARKERCOLORCOL = 30 'couleur marqueur 
Const MARKERSIZECOL = 31  'taille marqueur 
Const MARKERIMAGECOL = 29 'image marqueur 
Const LABELCOLORCOL = 30  'couleur label 
Const LABELSIZECOL = 31 'taille label 
Const NAMECOL = 1 'affichage type dans google map 
Const DESCRIPTIONCOL = 28 'affichage description dans google map 
Const FOLDERCOL = 3 'creation fichier dans google map 


' modele MARQUEUR 
Const PLACEMARKTEMPLATE = _ 
    "<Placemark>%CR%" & _ 
    "  <description>%description%</description>%CR%" & _ 
    "  <name>%name%</name>%CR%" & _ 
    "  <Style>%CR%" & _ 
    "  <IconStyle><scale>1</scale></IconStyle>" & _ 
    "%buttontemplate%" & _ 
    "%labeltemplate%" & _ 
    "  </Style>%CR%" & _ 
    "  <visibility>1</visibility>%CR%" & _ 
    "  <Point>%CR%" & _ 
    "    <coordinates>%longitude%, %latitude%, 0</coordinates>%CR%" & _ 
    "  </Point>%CR%" & _ 
    "</Placemark>%CR%%CR%" 

'     "      <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 

'modele BOUTON 
Const BUTTONTEMPLATE = _ 
    "    <IconStyle>%CR%" & _ 
    "%buttoncolortemplate%" & _ 
    "%buttonscaletemplate%" & _ 
    "      <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 
    "    </IconStyle>%CR%" 
     
     
Const BUTTONCOLORTEMPLATE = "      <color>%buttoncolor%</color>%CR%" 
Const BUTTONSCALETEMPLATE = "      <scale>%buttonscale%</scale>%CR%" 

Const LABELTEMPLATE = "    <LabelStyle>%labelcolortemplate%%labelscaletemplate%</LabelStyle>%CR%" 

Const LABELCOLORTEMPLATE = "<color>ff%labelcolor%</color>" 
Const LABELSCALETEMPLATE = "<scale>%labelscale%</scale>" 


'variables sortie KML 
Dim s As String 
Dim name As String 
Dim description As String 
Dim markercolor As String 
Dim markerscale As String 
Dim markerimage As String 
Dim labelcolor As String 
Dim labelscale As String 
Dim latitude As String 
Dim longitude As String 
Dim folder As String 
Dim prevfolder As String 
Dim lastrow As Integer 
Dim sFileName As String 



'************************************************************************************************************************************************** 
'************************************************************************************************************************************************** 
'CREATION DU FICHIER KML 
'************************************************************************************************************************************************** 
'************************************************************************************************************************************************** 

Sub OutputKML() 

  'Afficher la boîte de dialogue Ouvrir et affecter le nom de fichier sélectionné 
  ' à la variable de la chaîne 'sFileName' 
    sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Où voulez-vous enregistrer votre fichier KML?", "Enregistrer") 
     
    ' Si l'utilisateur a annulé 
    If sFileName = "False" Then Exit Sub 
     
    'Call ConvertirNumerique 
     
    Open CStr(sFileName) For Output As #1 
     
    ' à faire pour tous les dossiers 
    prevfolder = "***BLANK***" 
     
    Print #1, StartKML 
     
    lastrow = LastDataRow 
     
    For r = FIRSTDATAROW To lastrow 
         
        name = CStr(ActiveSheet.Cells(r, NAMECOL)) 
        description = CStr(ActiveSheet.Cells(r, DESCRIPTIONCOL)) 
         
        markercolor = ActiveSheet.Cells(r, MARKERCOLORCOL) 
        markerscale = ActiveSheet.Cells(r, MARKERSIZECOL) 
        markerimage = ActiveSheet.Cells(r, MARKERIMAGECOL) 
        labelcolor = ActiveSheet.Cells(r, LABELCOLORCOL) 
        labelscale = ActiveSheet.Cells(r, LABELSIZECOL) 
        folder = ActiveSheet.Cells(r, FOLDERCOL) 
         
        latitude = ActiveSheet.Cells(r, LATITUDECOL) 
        longitude = ActiveSheet.Cells(r, LONGITUDECOL) 
         
        If folder <> prevfolder Then 
            If prevfolder <> "***BLANK***" Then Print #1, EndFolder 
              Print #1, StartFolder(folder) 
        End If 
        prevfolder = folder 
         
        If latitude <> "" And latitude <> "not found" Then 
            Print #1, KMLMakePlacemarkString(name, description, markerimage, markercolor, markerscale, labelcolor, labelscale, latitude, longitude) 
        End If 
    Next r 
     
    Print #1, EndFolder 
    Print #1, EndKML 
    Close #1 
     
    'Shell (CStr([GoogleEarthExecutableLocation]) & " " & sFileName) 
     
End Sub 

'********************************************************************************************************************************************************************************* 
'********************************************************************************************************************************************************************************* 
'FONCTION POUR CREATION FICHIER KML 
'********************************************************************************************************************************************************************************* 
'********************************************************************************************************************************************************************************* 


'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER EN-TETE FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function StartKML() As String 

    StartKML = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & _ 
                    "<kml xmlns=""http://earth.google.com/kml/2.0"">" & vbCrLf & "<Document>" & vbCrLf 
                     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER FIN FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function EndKML() As String 

    EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER DEBUT FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function StartFolder(folderName As String) As String 

    StartFolder = "   <Folder>" & vbCrLf & _ 
                  "      <name>" & folderName & "</name>" & vbCrLf & _ 
                  "      <visibility>1</visibility>" & vbCrLf & _ 
                  "      <open>1</open>" & vbCrLf 
                   
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER FIN FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function EndFolder() As String 

    EndFolder = "   </Folder>" & vbCrLf 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER REMPLISSAGE KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function KMLFromRow() 

    r = ActiveCell.Row() 
     
    Debug.Print KMLMakePlacemark(CStr(Cells(r, 10)), _ 
                                 CStr(Cells(r, 11)), _ 
                                 CStr(Cells(r, 9)), _ 
                                 CStr(Cells(r, 6)), _ 
                                 CStr(Cells(r, 7))) 
                                  
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER MODELE KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function template(templatestr As String, replacements As Collection) As String 

  'variable pour modele 
    Dim findreplace 
    Dim strFind As String 
    Dim strReplace As String 


    For Each findreplace In replacements 
        strFind = findreplace(0) 
        strReplace = findreplace(1) 
        templatestr = Replace(templatestr, "%" & strFind & "%", strReplace) 
    Next findreplace 
    template = templatestr 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER MODELE MARQUEUR KML 
'******************************************************************************************************** 
'******************************************************************************************************** 


Function KMLMakePlacemarkString(name As String, _ 
                                description As String, _ 
                                buttonimage As String, _ 
                                buttoncolor As String, _ 
                                buttonscale As String, _ 
                                labelcolor As String, _ 
                                labelscale As String, _ 
                                latitude As String, _ 
                                longitude As String) As String 
     
     
    'variables placemarker 
    Dim repl As New Collection 

     
     
    name = RegExValidate(name, "[a-zA-Z0-9-]") 
    'description = RegExValidate(description, "[a-zA-Z0-9,\(\)<>!\[\] ]") 
   
    repl.Add Array("description", description) 
    repl.Add Array("name", name) 
     
    If buttonimage <> "" Then 
        repl.Add Array("buttontemplate", BUTTONTEMPLATE) 
        If buttoncolor <> "" Then repl.Add Array("buttoncolortemplate", BUTTONCOLORTEMPLATE) 
        If buttonscale <> "" Then repl.Add Array("buttonscaletemplate", BUTTONSCALETEMPLATE) 
    End If 
    repl.Add Array("buttonimage", buttonimage) 
    repl.Add Array("buttoncolor", buttoncolor) 
    repl.Add Array("buttonscale", buttonscale) 
    repl.Add Array("buttoncolortemplate", "") 
    repl.Add Array("buttonscaletemplate", "") 
    repl.Add Array("buttontemplate", "") 
     
    If labelcolor <> "" Or labelscale <> "" Then 
        repl.Add Array("labeltemplate", LABELTEMPLATE) 
        If labelcolor <> "" Then repl.Add Array("labelcolortemplate", LABELCOLORTEMPLATE) 
        If labelscale <> "" Then repl.Add Array("labelscaletemplate", LABELSCALETEMPLATE) 
    End If 
    repl.Add Array("labelcolor", labelcolor) 
    repl.Add Array("labelscale", labelscale) 
    repl.Add Array("labelcolortemplate", "") 
    repl.Add Array("labelscaletemplate", "") 
    repl.Add Array("labeltemplate", "") 
     
    repl.Add Array("latitude", latitude) 
    repl.Add Array("longitude", longitude) 
    repl.Add Array("CR", vbCrLf) 
     
    KMLMakePlacemarkString = template(PLACEMARKTEMPLATE, repl) 
     
End Function 

Private Function max(a, b): 

    If a > b Then 
        max = a 
    Else 
        max = b 
    End If 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'DERNIERE LIGNE REMPLIE DU TABLEAU FILTRATION 
'******************************************************************************************************** 
'******************************************************************************************************** 

' recherche la dernière ligne qui contient une adresse 
Function LastDataRow() As Integer 

    Dim r As Integer 
     
    activecelladdr = ActiveCell.Address 

    Range("i65536").End(xlUp).Select  'adresse 
    r = ActiveCell.Row() 
     
    Range("j65536").End(xlUp).Select  'code postal 
    r = max(r, ActiveCell.Row()) 
     
    Range("k65536").End(xlUp).Select  'commune 
    r = max(r, ActiveCell.Row()) 
     
    Range(activecelladdr).Select 
    LastDataRow = r 
     
End Function 

' Renvoie une chaîne de caractères contenant uniquement des caractères dans la source 
' qui correspondent aux éléments de test. 
' 
' Exemple: RegExValidate("chris gemignani","aeiou") returns "eiai" 

Public Function RegExValidate(ByRef Source As String, _ 
                              ByRef TEST As String) As String 

    Dim s As String 
    Dim regex As Object 
    Set regex = CreateObject("vbscript.regexp") 
     
    With regex 
        .Pattern = TEST 
        .Global = True 
    End With 
     
    Dim matches As Object 
    Set matches = regex.Execute(Source) 
     
    s = "" 
    For Each m In matches 
        s = s & m 
    Next m 
    RegExValidate = s 
End Function




Code à installer dans 1 module pour l'utilisation du clipboard

' Ce module définit une fonction qui vous permet de conserver des données textuelles dans le presse-papier. 


'declaration fonctions 
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ 
   ByVal dwBytes As Long) As Long 
Declare Function CloseClipboard Lib "User32" () As Long 
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ 
   As Long 
Declare Function EmptyClipboard Lib "User32" () As Long 
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
   ByVal lpString2 As Any) As Long 
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ 
   As Long, ByVal hMem As Long) As Long 

'declaratation constantes 
Public Const GHND = &H42 
Public Const CF_TEXT = 1 
Public Const MAXSIZE = 4096 

'declaration variables 
Dim hGlobalMemory As Long 
Dim lpGlobalMemory As Long 
Dim hClipMemory As Long 
Dim x As Long 

                     

Function ClipBoard_SetData(MyString As String) 
    
   ' Allouez la mémoire globale mobile. 
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) 

   ' Verrouiller le bloc  pour obtenir un pointeur vers cette mémoire. 
   lpGlobalMemory = GlobalLock(hGlobalMemory) 

   ' Copie la chaîne dans cette mémoire globale. 
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) 

   ' Déverrouiller la mémoire. 
   If GlobalUnlock(hGlobalMemory) <> 0 Then 
      MsgBox "Impossible de déverrouiller l'emplacement de la mémoire. Copie interrompue. " 
      GoTo OutOfHere2 
   End If 

   ' Ouvrir le presse-papiers pour copier les données. 
   If OpenClipboard(0&) = 0 Then 
      MsgBox "Impossible d'ouvrir le Presse-papiers. Copie interrompue." 
      Exit Function 
   End If 

   ' Effacer le presse papier. 
   x = EmptyClipboard() 

   ' Copier les données dans le presse papier. 
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 

OutOfHere2: 

   If CloseClipboard() = 0 Then 
      MsgBox "Impossible de fermer le presse-papiers." 
   End If 

End Function



Code à installer dans 1 module pour activer le lien pour google earth

' Ce module définit une fonction qui vous permet de conserver des données textuelles dans le presse-papier. 


'declaration fonctions 
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ 
   ByVal dwBytes As Long) As Long 
Declare Function CloseClipboard Lib "User32" () As Long 
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ 
   As Long 
Declare Function EmptyClipboard Lib "User32" () As Long 
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
   ByVal lpString2 As Any) As Long 
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ 
   As Long, ByVal hMem As Long) As Long 

'declaratation constantes 
Public Const GHND = &H42 
Public Const CF_TEXT = 1 
Public Const MAXSIZE = 4096 

'declaration variables 
Dim hGlobalMemory As Long 
Dim lpGlobalMemory As Long 
Dim hClipMemory As Long 
Dim x As Long 

                     

Function ClipBoard_SetData(MyString As String) 
    
   ' Allouez la mémoire globale mobile. 
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) 

   ' Verrouiller le bloc  pour obtenir un pointeur vers cette mémoire. 
   lpGlobalMemory = GlobalLock(hGlobalMemory) 

   ' Copie la chaîne dans cette mémoire globale. 
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) 

   ' Déverrouiller la mémoire. 
   If GlobalUnlock(hGlobalMemory) <> 0 Then 
      MsgBox "Impossible de déverrouiller l'emplacement de la mémoire. Copie interrompue. " 
      GoTo OutOfHere2 
   End If 

   ' Ouvrir le presse-papiers pour copier les données. 
   If OpenClipboard(0&) = 0 Then 
      MsgBox "Impossible d'ouvrir le Presse-papiers. Copie interrompue." 
      Exit Function 
   End If 

   ' Effacer le presse papier. 
   x = EmptyClipboard() 

   ' Copier les données dans le presse papier. 
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 

OutOfHere2: 

   If CloseClipboard() = 0 Then 
      MsgBox "Impossible de fermer le presse-papiers." 
   End If 

End Function


Références à démarrer dans VBA d'excel:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0


A adapter selon tes feuilles. et tes colonnes contenant les infos voulues

Cordialement
Bonjour,

Votre code est très intéressant et j'aimerai bien l'utiliser pour réaliser une application mais j'ai besoin du fichier excel correspondant à ce code pour mieux le comprendre et l'adapter à mon besoin.

Cordialement,
Bonjour;
Code provenant de A.SIMON et JUICE ANALYTIC et modifier pour mon fichier

Code à mettre dans 1 module pour generer KML à partir d'excel:

OPTION EXPLICIT 

'************************************************************************************************************* 
'************************************************************************************************************* 
'DECLARATION DE VARIABLES ET DES CONSTANTES 
'************************************************************************************************************* 
'************************************************************************************************************* 

Public folders As New Collection 
Const FIRSTDATAROW = 13  'premiere ligne active 
Const LATITUDECOL = 26  'colonne latitude 
Const LONGITUDECOL = 27 'colonne longitude 
Const MARKERCOLORCOL = 30 'couleur marqueur 
Const MARKERSIZECOL = 31  'taille marqueur 
Const MARKERIMAGECOL = 29 'image marqueur 
Const LABELCOLORCOL = 30  'couleur label 
Const LABELSIZECOL = 31 'taille label 
Const NAMECOL = 1 'affichage type dans google map 
Const DESCRIPTIONCOL = 28 'affichage description dans google map 
Const FOLDERCOL = 3 'creation fichier dans google map 


' modele MARQUEUR 
Const PLACEMARKTEMPLATE = _ 
    "<Placemark>%CR%" & _ 
    "  <description>%description%</description>%CR%" & _ 
    "  <name>%name%</name>%CR%" & _ 
    "  <Style>%CR%" & _ 
    "  <IconStyle><scale>1</scale></IconStyle>" & _ 
    "%buttontemplate%" & _ 
    "%labeltemplate%" & _ 
    "  </Style>%CR%" & _ 
    "  <visibility>1</visibility>%CR%" & _ 
    "  <Point>%CR%" & _ 
    "    <coordinates>%longitude%, %latitude%, 0</coordinates>%CR%" & _ 
    "  </Point>%CR%" & _ 
    "</Placemark>%CR%%CR%" 

'     "      <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 

'modele BOUTON 
Const BUTTONTEMPLATE = _ 
    "    <IconStyle>%CR%" & _ 
    "%buttoncolortemplate%" & _ 
    "%buttonscaletemplate%" & _ 
    "      <Icon><href>http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png</href></Icon>%CR%" & _ 
    "    </IconStyle>%CR%" 
     
     
Const BUTTONCOLORTEMPLATE = "      <color>%buttoncolor%</color>%CR%" 
Const BUTTONSCALETEMPLATE = "      <scale>%buttonscale%</scale>%CR%" 

Const LABELTEMPLATE = "    <LabelStyle>%labelcolortemplate%%labelscaletemplate%</LabelStyle>%CR%" 

Const LABELCOLORTEMPLATE = "<color>ff%labelcolor%</color>" 
Const LABELSCALETEMPLATE = "<scale>%labelscale%</scale>" 


'variables sortie KML 
Dim s As String 
Dim name As String 
Dim description As String 
Dim markercolor As String 
Dim markerscale As String 
Dim markerimage As String 
Dim labelcolor As String 
Dim labelscale As String 
Dim latitude As String 
Dim longitude As String 
Dim folder As String 
Dim prevfolder As String 
Dim lastrow As Integer 
Dim sFileName As String 



'************************************************************************************************************************************************** 
'************************************************************************************************************************************************** 
'CREATION DU FICHIER KML 
'************************************************************************************************************************************************** 
'************************************************************************************************************************************************** 

Sub OutputKML() 

  'Afficher la boîte de dialogue Ouvrir et affecter le nom de fichier sélectionné 
  ' à la variable de la chaîne 'sFileName' 
    sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Où voulez-vous enregistrer votre fichier KML?", "Enregistrer") 
     
    ' Si l'utilisateur a annulé 
    If sFileName = "False" Then Exit Sub 
     
    'Call ConvertirNumerique 
     
    Open CStr(sFileName) For Output As #1 
     
    ' à faire pour tous les dossiers 
    prevfolder = "***BLANK***" 
     
    Print #1, StartKML 
     
    lastrow = LastDataRow 
     
    For r = FIRSTDATAROW To lastrow 
         
        name = CStr(ActiveSheet.Cells(r, NAMECOL)) 
        description = CStr(ActiveSheet.Cells(r, DESCRIPTIONCOL)) 
         
        markercolor = ActiveSheet.Cells(r, MARKERCOLORCOL) 
        markerscale = ActiveSheet.Cells(r, MARKERSIZECOL) 
        markerimage = ActiveSheet.Cells(r, MARKERIMAGECOL) 
        labelcolor = ActiveSheet.Cells(r, LABELCOLORCOL) 
        labelscale = ActiveSheet.Cells(r, LABELSIZECOL) 
        folder = ActiveSheet.Cells(r, FOLDERCOL) 
         
        latitude = ActiveSheet.Cells(r, LATITUDECOL) 
        longitude = ActiveSheet.Cells(r, LONGITUDECOL) 
         
        If folder <> prevfolder Then 
            If prevfolder <> "***BLANK***" Then Print #1, EndFolder 
              Print #1, StartFolder(folder) 
        End If 
        prevfolder = folder 
         
        If latitude <> "" And latitude <> "not found" Then 
            Print #1, KMLMakePlacemarkString(name, description, markerimage, markercolor, markerscale, labelcolor, labelscale, latitude, longitude) 
        End If 
    Next r 
     
    Print #1, EndFolder 
    Print #1, EndKML 
    Close #1 
     
    'Shell (CStr([GoogleEarthExecutableLocation]) & " " & sFileName) 
     
End Sub 

'********************************************************************************************************************************************************************************* 
'********************************************************************************************************************************************************************************* 
'FONCTION POUR CREATION FICHIER KML 
'********************************************************************************************************************************************************************************* 
'********************************************************************************************************************************************************************************* 


'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER EN-TETE FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function StartKML() As String 

    StartKML = "<?xml version=""1.0"" encoding=""UTF-8""?>" & vbCrLf & _ 
                    "<kml xmlns=""http://earth.google.com/kml/2.0"">" & vbCrLf & "<Document>" & vbCrLf 
                     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER FIN FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function EndKML() As String 

    EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER DEBUT FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function StartFolder(folderName As String) As String 

    StartFolder = "   <Folder>" & vbCrLf & _ 
                  "      <name>" & folderName & "</name>" & vbCrLf & _ 
                  "      <visibility>1</visibility>" & vbCrLf & _ 
                  "      <open>1</open>" & vbCrLf 
                   
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER FIN FICHIER KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function EndFolder() As String 

    EndFolder = "   </Folder>" & vbCrLf 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER REMPLISSAGE KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function KMLFromRow() 

    r = ActiveCell.Row() 
     
    Debug.Print KMLMakePlacemark(CStr(Cells(r, 10)), _ 
                                 CStr(Cells(r, 11)), _ 
                                 CStr(Cells(r, 9)), _ 
                                 CStr(Cells(r, 6)), _ 
                                 CStr(Cells(r, 7))) 
                                  
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER MODELE KML 
'******************************************************************************************************** 
'******************************************************************************************************** 

Function template(templatestr As String, replacements As Collection) As String 

  'variable pour modele 
    Dim findreplace 
    Dim strFind As String 
    Dim strReplace As String 


    For Each findreplace In replacements 
        strFind = findreplace(0) 
        strReplace = findreplace(1) 
        templatestr = Replace(templatestr, "%" & strFind & "%", strReplace) 
    Next findreplace 
    template = templatestr 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'FICHIER MODELE MARQUEUR KML 
'******************************************************************************************************** 
'******************************************************************************************************** 


Function KMLMakePlacemarkString(name As String, _ 
                                description As String, _ 
                                buttonimage As String, _ 
                                buttoncolor As String, _ 
                                buttonscale As String, _ 
                                labelcolor As String, _ 
                                labelscale As String, _ 
                                latitude As String, _ 
                                longitude As String) As String 
     
     
    'variables placemarker 
    Dim repl As New Collection 

     
     
    name = RegExValidate(name, "[a-zA-Z0-9-]") 
    'description = RegExValidate(description, "[a-zA-Z0-9,\(\)<>!\[\] ]") 
   
    repl.Add Array("description", description) 
    repl.Add Array("name", name) 
     
    If buttonimage <> "" Then 
        repl.Add Array("buttontemplate", BUTTONTEMPLATE) 
        If buttoncolor <> "" Then repl.Add Array("buttoncolortemplate", BUTTONCOLORTEMPLATE) 
        If buttonscale <> "" Then repl.Add Array("buttonscaletemplate", BUTTONSCALETEMPLATE) 
    End If 
    repl.Add Array("buttonimage", buttonimage) 
    repl.Add Array("buttoncolor", buttoncolor) 
    repl.Add Array("buttonscale", buttonscale) 
    repl.Add Array("buttoncolortemplate", "") 
    repl.Add Array("buttonscaletemplate", "") 
    repl.Add Array("buttontemplate", "") 
     
    If labelcolor <> "" Or labelscale <> "" Then 
        repl.Add Array("labeltemplate", LABELTEMPLATE) 
        If labelcolor <> "" Then repl.Add Array("labelcolortemplate", LABELCOLORTEMPLATE) 
        If labelscale <> "" Then repl.Add Array("labelscaletemplate", LABELSCALETEMPLATE) 
    End If 
    repl.Add Array("labelcolor", labelcolor) 
    repl.Add Array("labelscale", labelscale) 
    repl.Add Array("labelcolortemplate", "") 
    repl.Add Array("labelscaletemplate", "") 
    repl.Add Array("labeltemplate", "") 
     
    repl.Add Array("latitude", latitude) 
    repl.Add Array("longitude", longitude) 
    repl.Add Array("CR", vbCrLf) 
     
    KMLMakePlacemarkString = template(PLACEMARKTEMPLATE, repl) 
     
End Function 

Private Function max(a, b): 

    If a > b Then 
        max = a 
    Else 
        max = b 
    End If 
     
End Function 

'******************************************************************************************************* 
'******************************************************************************************************* 
'DERNIERE LIGNE REMPLIE DU TABLEAU FILTRATION 
'******************************************************************************************************** 
'******************************************************************************************************** 

' recherche la dernière ligne qui contient une adresse 
Function LastDataRow() As Integer 

    Dim r As Integer 
     
    activecelladdr = ActiveCell.Address 

    Range("i65536").End(xlUp).Select  'adresse 
    r = ActiveCell.Row() 
     
    Range("j65536").End(xlUp).Select  'code postal 
    r = max(r, ActiveCell.Row()) 
     
    Range("k65536").End(xlUp).Select  'commune 
    r = max(r, ActiveCell.Row()) 
     
    Range(activecelladdr).Select 
    LastDataRow = r 
     
End Function 

' Renvoie une chaîne de caractères contenant uniquement des caractères dans la source 
' qui correspondent aux éléments de test. 
' 
' Exemple: RegExValidate("chris gemignani","aeiou") returns "eiai" 

Public Function RegExValidate(ByRef Source As String, _ 
                              ByRef TEST As String) As String 

    Dim s As String 
    Dim regex As Object 
    Set regex = CreateObject("vbscript.regexp") 
     
    With regex 
        .Pattern = TEST 
        .Global = True 
    End With 
     
    Dim matches As Object 
    Set matches = regex.Execute(Source) 
     
    s = "" 
    For Each m In matches 
        s = s & m 
    Next m 
    RegExValidate = s 
End Function 


Code à installer dans 1 module pour l'utilisation du clipboard

' Ce module définit une fonction qui vous permet de conserver des données textuelles dans le presse-papier. 


'declaration fonctions 
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ 
   ByVal dwBytes As Long) As Long 
Declare Function CloseClipboard Lib "User32" () As Long 
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ 
   As Long 
Declare Function EmptyClipboard Lib "User32" () As Long 
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
   ByVal lpString2 As Any) As Long 
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ 
   As Long, ByVal hMem As Long) As Long 

'declaratation constantes 
Public Const GHND = &H42 
Public Const CF_TEXT = 1 
Public Const MAXSIZE = 4096 

'declaration variables 
Dim hGlobalMemory As Long 
Dim lpGlobalMemory As Long 
Dim hClipMemory As Long 
Dim x As Long 

                     

Function ClipBoard_SetData(MyString As String) 
    
   ' Allouez la mémoire globale mobile. 
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) 

   ' Verrouiller le bloc  pour obtenir un pointeur vers cette mémoire. 
   lpGlobalMemory = GlobalLock(hGlobalMemory) 

   ' Copie la chaîne dans cette mémoire globale. 
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) 

   ' Déverrouiller la mémoire. 
   If GlobalUnlock(hGlobalMemory) <> 0 Then 
      MsgBox "Impossible de déverrouiller l'emplacement de la mémoire. Copie interrompue. " 
      GoTo OutOfHere2 
   End If 

   ' Ouvrir le presse-papiers pour copier les données. 
   If OpenClipboard(0&) = 0 Then 
      MsgBox "Impossible d'ouvrir le Presse-papiers. Copie interrompue." 
      Exit Function 
   End If 

   ' Effacer le presse papier. 
   x = EmptyClipboard() 

   ' Copier les données dans le presse papier. 
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 

OutOfHere2: 

   If CloseClipboard() = 0 Then 
      MsgBox "Impossible de fermer le presse-papiers." 
   End If 

End Function 



Code à installer dans 1 module pour activer le lien pour google earth

' Ce module définit une fonction qui vous permet de conserver des données textuelles dans le presse-papier. 


'declaration fonctions 
Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) _ 
   As Long 
Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, _ 
   ByVal dwBytes As Long) As Long 
Declare Function CloseClipboard Lib "User32" () As Long 
Declare Function OpenClipboard Lib "User32" (ByVal hwnd As Long) _ 
   As Long 
Declare Function EmptyClipboard Lib "User32" () As Long 
Declare Function lstrcpy Lib "kernel32" (ByVal lpString1 As Any, _ 
   ByVal lpString2 As Any) As Long 
Declare Function SetClipboardData Lib "User32" (ByVal wFormat _ 
   As Long, ByVal hMem As Long) As Long 

'declaratation constantes 
Public Const GHND = &H42 
Public Const CF_TEXT = 1 
Public Const MAXSIZE = 4096 

'declaration variables 
Dim hGlobalMemory As Long 
Dim lpGlobalMemory As Long 
Dim hClipMemory As Long 
Dim x As Long 

                     

Function ClipBoard_SetData(MyString As String) 
    
   ' Allouez la mémoire globale mobile. 
   hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) 

   ' Verrouiller le bloc  pour obtenir un pointeur vers cette mémoire. 
   lpGlobalMemory = GlobalLock(hGlobalMemory) 

   ' Copie la chaîne dans cette mémoire globale. 
   lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) 

   ' Déverrouiller la mémoire. 
   If GlobalUnlock(hGlobalMemory) <> 0 Then 
      MsgBox "Impossible de déverrouiller l'emplacement de la mémoire. Copie interrompue. " 
      GoTo OutOfHere2 
   End If 

   ' Ouvrir le presse-papiers pour copier les données. 
   If OpenClipboard(0&) = 0 Then 
      MsgBox "Impossible d'ouvrir le Presse-papiers. Copie interrompue." 
      Exit Function 
   End If 

   ' Effacer le presse papier. 
   x = EmptyClipboard() 

   ' Copier les données dans le presse papier. 
   hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) 

OutOfHere2: 

   If CloseClipboard() = 0 Then 
      MsgBox "Impossible de fermer le presse-papiers." 
   End If 

End Function 


Références à démarrer dans VBA d'excel:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0


A adapter selon tes feuilles.

Cordialement.

Oups doublon....
désolé
La référence xlm v6.0 est inutile car cela ne me sert pour geocoder mes adresses contenues dans le fichier excel
Messages postés
23989
Date d'inscription
mardi 11 septembre 2007
Statut
Contributeur
Dernière intervention
8 avril 2021
6 719
Bonjour,

Ton code a l'air intéressant.
Pourrais-tu déposer un petit fichier xls avec le code et 3 lignes de datas qu'on voit comment elles sont attendues ?
Déposer le fichier xls sur cjoint.com et coller ici le lien fourni.
Merci

eric