Convertir fichier excel en fichier kml

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

' 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

' 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

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 

' 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 

' 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