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
