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!
A voir également:
Fichier kml
Créer fichier kml avec excel - Meilleures réponses
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.
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
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
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.
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
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
