Convert Excel file to KML file
vasili86
Posted messages
2
Registration date
Status
Membre
Last intervention
-
IngenieurEE -
IngenieurEE -
Hello,
I am a beginner in VBA and I need to create a KML file for an application in Google Earth from an Excel file. To do this, I have created a graphical interface with a button that allows me to save the KML file to a chosen location. However, I haven't found a code to convert an Excel file into a KML file, which is why I'm reaching out for your expertise; perhaps you could help me out, thank you in advance!
I am a beginner in VBA and I need to create a KML file for an application in Google Earth from an Excel file. To do this, I have created a graphical interface with a button that allows me to save the KML file to a chosen location. However, I haven't found a code to convert an Excel file into a KML file, which is why I'm reaching out for your expertise; perhaps you could help me out, thank you in advance!
6 réponses
Hello,
I wouldn't say it's impossible since a KML file is just a text file.
You still need to know what to put in it, so there's significant preparatory work involved.
Here you can find a description and the syntax of KML files: https://developers.google.com/maps/documentation/javascript/kmllayer?hl=en
But I find it hard to believe that with a bit more searching online you wouldn't find a pre-made file that does this.
On the Google forum, for example: https://productforums.google.com/forum/#!searchin/gec/excel
Yours has the particularity of displaying a table in the description. But for someone used to creating HTML pages, it shouldn't pose too many difficulties (?)
And rather than creating a KML file, maybe you can use the Google Earth APIs directly: https://cloud.google.com/maps-platform/?hl=en
But I think there might be a limitation on the number of data sent or the number of requests in a certain timeframe, worth checking out.
To encourage contributors, you should upload an XLS file with 3-4 points and the corresponding KML file.
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
You will never respond to an unsolicited DM...
Well, that's done.
I wouldn't say it's impossible since a KML file is just a text file.
You still need to know what to put in it, so there's significant preparatory work involved.
Here you can find a description and the syntax of KML files: https://developers.google.com/maps/documentation/javascript/kmllayer?hl=en
But I find it hard to believe that with a bit more searching online you wouldn't find a pre-made file that does this.
On the Google forum, for example: https://productforums.google.com/forum/#!searchin/gec/excel
Yours has the particularity of displaying a table in the description. But for someone used to creating HTML pages, it shouldn't pose too many difficulties (?)
And rather than creating a KML file, maybe you can use the Google Earth APIs directly: https://cloud.google.com/maps-platform/?hl=en
But I think there might be a limitation on the number of data sent or the number of requests in a certain timeframe, worth checking out.
To encourage contributors, you should upload an XLS file with 3-4 points and the corresponding KML file.
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
You will never respond to an unsolicited DM...
Well, that's done.
Hello,
To my knowledge --> it's impossible
What is it for?
See you later
--
If you bang your head against a pot and it sounds hollow, it’s not necessarily the pot that’s empty. ;-)(Confucius)
Note: I don't reply to private messages for technical questions. And my crystal ball is broken.
To my knowledge --> it's impossible
What is it for?
See you later
--
If you bang your head against a pot and it sounds hollow, it’s not necessarily the pot that’s empty. ;-)(Confucius)
Note: I don't reply to private messages for technical questions. And my crystal ball is broken.
Hello, this is to create a tracking tool that allows monitoring the network's performance through KPIs (key performance indicators) which are the information found in the Excel file.
This means I have an Excel file where each line represents a station and the information about that station (name, coordinates, etc.) and from this file, I need to have another file but in geographic mode with Google Earth for example, and Google Earth only reads KML files, so I will convert this Excel file into a KML file and open it with Google Earth!
Here are 2 figures that explain!
The first one represents an example of an Excel file
http://www.hostingpics.net/viewer.php?id=154731Sanstitre.jpg
The second one represents an example of KML file representation in Google Earth
http://www.hostingpics.net/viewer.php?id=617527Capture.jpg
This means I have an Excel file where each line represents a station and the information about that station (name, coordinates, etc.) and from this file, I need to have another file but in geographic mode with Google Earth for example, and Google Earth only reads KML files, so I will convert this Excel file into a KML file and open it with Google Earth!
Here are 2 figures that explain!
The first one represents an example of an Excel file
http://www.hostingpics.net/viewer.php?id=154731Sanstitre.jpg
The second one represents an example of KML file representation in Google Earth
http://www.hostingpics.net/viewer.php?id=617527Capture.jpg
Hello;
Code to be placed in a module to generate KML from Excel:
Code to be installed in a module for clipboard usage
Code to be installed in a module to activate the link for Google Earth
References to start in Excel VBA:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0
To be adapted according to your sheets and the columns containing the desired information
Best regards
Code to be placed in a module to generate KML from Excel:
OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'VARIABLE AND CONSTANTS DECLARATION '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'first active row Const LATITUDECOL = 26 'latitude column Const LONGITUDECOL = 27 'longitude column Const MARKERCOLORCOL = 30 'marker color Const MARKERSIZECOL = 31 'marker size Const MARKERIMAGECOL = 29 'marker image Const LABELCOLORCOL = 30 'label color Const LABELSIZECOL = 31 'label size Const NAMECOL = 1 'display type in google map Const DESCRIPTIONCOL = 28 'display description in google map Const FOLDERCOL = 3 'file creation in google map ' marker template 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%" & _ 'button template 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>" 'KML output variables 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 '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'KML FILE CREATION '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Display the Open dialog box and assign the selected filename ' to the string variable 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Where do you want to save your KML file?", "Save") ' If the user canceled If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 ' to do for all folders 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 '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCTION FOR CREATING KML FILE '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'HEADER FILE 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 '******************************************************************************************************* '******************************************************************************************************* 'END FILE KML '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'START FILE 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 '******************************************************************************************************* '******************************************************************************************************* 'END FILE KML '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " </Folder>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'FILLING KML FILE '******************************************************************************************************** '******************************************************************************************************** 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 '******************************************************************************************************* '******************************************************************************************************* 'KML TEMPLATE FILE '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable for template 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 '******************************************************************************************************* '******************************************************************************************************* 'KML MARKER TEMPLATE FILE '******************************************************************************************************** '******************************************************************************************************** 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 'placemarker variables 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 '******************************************************************************************************* '******************************************************************************************************* 'LAST FILLED ROW OF TABLE FILTER '******************************************************************************************************** '******************************************************************************************************** ' finds the last row that contains an address Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'address r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'postal code r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'city r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Returns a string containing only characters from the source ' that match the test items. ' ' For example: 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 to be installed in a module for clipboard usage
' This module defines a function that allows you to keep text data in the clipboard. 'function declarations 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 'constant declaration Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate movable global memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock the memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy the data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear the clipboard. x = EmptyClipboard() ' Copy the data to the clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close the clipboard." End If End Function
Code to be installed in a module to activate the link for Google Earth
' This module defines a function that allows you to keep text data in the clipboard. 'function declarations 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 'constant declaration Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate movable global memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock the memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy the data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear the clipboard. x = EmptyClipboard() ' Copy the data to the clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close the clipboard." End If End Function
References to start in Excel VBA:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0
To be adapted according to your sheets and the columns containing the desired information
Best regards
Hello;
Code from A.SIMON and JUICE ANALYTIC modified for my file
Code to put in 1 module to generate KML from Excel:
Code to install in 1 module for clipboard usage
Code to install in 1 module to activate the link for Google Earth
References to start in Excel VBA:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0
To be adapted according to your sheets.
Best regards.
Oops duplicate....
sorry
Code from A.SIMON and JUICE ANALYTIC modified for my file
Code to put in 1 module to generate KML from Excel:
OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'VARIABLE AND CONSTANTS DECLARATION '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'first active row Const LATITUDECOL = 26 'latitude column Const LONGITUDECOL = 27 'longitude column Const MARKERCOLORCOL = 30 'marker color Const MARKERSIZECOL = 31 'marker size Const MARKERIMAGECOL = 29 'marker image Const LABELCOLORCOL = 30 'label color Const LABELSIZECOL = 31 'label size Const NAMECOL = 1 'display type in google map Const DESCRIPTIONCOL = 28 'display description in google map Const FOLDERCOL = 3 'create file in google map ' marker model 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%" & _ 'button model 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>" 'KML output variables 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 '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'KML FILE CREATION '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Show the Open dialog box and set the selected file name 'to the string variable 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "Where do you want to save your KML file?", "Save") ' If the user canceled If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 ' to do for all folders 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 '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCTION FOR CREATING KML FILE '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'KML FILE HEADER '******************************************************************************************************** '******************************************************************************************************** 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 '******************************************************************************************************* '******************************************************************************************************* 'KML FILE END '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "</Document>" & vbCrLf & "</kml>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILE START '******************************************************************************************************** '******************************************************************************************************** Function StartFolder(folderName As String) As String StartFolder = " <Folder>" & vbCrLf & _ " <name>" & folderName & "</name>" & vbCrLf & _ " <visibility>1</visibility>" & vbCrLf & _ " <open>1</open>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILE END '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " </Folder>" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'KML FILLING FILE '******************************************************************************************************** '******************************************************************************************************** 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 '******************************************************************************************************* '******************************************************************************************************* 'KML MODEL FILE '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable for model 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 '******************************************************************************************************* '******************************************************************************************************* 'KML MARKER MODEL FILE '******************************************************************************************************** '******************************************************************************************************** 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 'placemarker variables 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 '******************************************************************************************************* '******************************************************************************************************* 'LAST FILLED LINE OF THE TABLE FILTERING '******************************************************************************************************** '******************************************************************************************************** ' searches for the last row containing an address Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'address r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'postal code r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'city r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Returns a string containing only characters in the source ' that match the test elements. ' ' Example: 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 to install in 1 module for clipboard usage
' This module defines a function that allows you to keep text data in the clipboard. 'function declarations 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 'constant declarations Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate global movable memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear clipboard. x = EmptyClipboard() ' Copy data to clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close clipboard." End If End Function
Code to install in 1 module to activate the link for Google Earth
' This module defines a function that allows you to keep text data in the clipboard. 'function declarations 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 'constant declarations Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'variable declaration Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Allocate global movable memory. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Lock the block to get a pointer to this memory. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copy the string into this global memory. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Unlock the memory. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "Unable to unlock memory location. Copy interrupted. " GoTo OutOfHere2 End If ' Open the clipboard to copy data. If OpenClipboard(0&) = 0 Then MsgBox "Unable to open the Clipboard. Copy interrupted." Exit Function End If ' Clear clipboard. x = EmptyClipboard() ' Copy data to clipboard. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "Unable to close clipboard." End If End Function
References to start in Excel VBA:
microsoft active X data object 2.8 library
microsoft active X data object recordset 2.8 library
microsoft xml v 6.0
To be adapted according to your sheets.
Best regards.
Oops duplicate....
sorry