convertir archivo excel a archivo kml

Question

Hola, Soy principiante en VBA y necesito crear un archivo KML para una aplicación en Google Earth a partir de un archivo de Excel. Para ello, he creado una interfaz gráfica con un botón que me permite guardar el archivo KML en un lugar elegido. Sin embargo, no he encontrado un código para convertir un archivo de Excel en un archivo KML. Por esta razón, recurro a su conocimiento, quizás pueda ayudarme, ¡gracias de antemano!

eriiic · Accepted Answer

Hola,  No diría que es imposible ya que un archivo KML no es más que un archivo de texto.  Todavía hay que saber qué poner dentro, así que es un trabajo preparatorio importante. Aquí encuentras una descripción y la sintaxis de los archivos KML: https://developers.google.com/maps/documentation/javascript/kmllayer?hl=fr Pero me sorprendería que, buscando un poco más en la red, no encuentres un archivo ya realizado que haga eso. En el foro de Google, por ejemplo: https://productforums.google.com/forum/#!searchin/gec/excel El tuyo tiene la particularidad de mostrar una tabla en la descripción. Pero para alguien acostumbrado a hacer páginas HTML no debería ser muy difícil (?)  Y en lugar de crear un archivo KML, quizás puedas utilizar directamente las API de Google Earth: https://cloud.google.com/maps-platform/?hl=fr Pero creo que hay una limitación en el número de datos enviados o en el número de solicitudes en un cierto tiempo, a considerar.  Para motivar a los colaboradores deberías subir un archivo XLS de 3-4 puntos y el archivo KML correspondiente.  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  Nunca responderás a un MP no solicitado... Bueno, eso ya está.

lermite222 · Answer

Hola, Hasta donde sé --> es imposible ¿Es para qué? Hasta luego   -- Si te das un golpe contra una olla y suena vacío, no necesariamente es la olla la que está vacía. ;-)(Confucio) Nota: No respondo a mensajes privados para preguntas técnicas. Y mi bola de cristal está rota.

vasili86 · Answer

Hola, es para realizar una herramienta de seguimiento que permite seguir el rendimiento de la red a través de los KPIs (indicadores clave de rendimiento) que son la información encontrada en el archivo de Excel  es decir, tengo un archivo de Excel donde cada fila representa una estación y la información sobre esta estación (nombre, coordenadas.......) y a partir de este archivo debo tener otro archivo pero en modo geográfico con Google Earth, por ejemplo, y Google Earth solo lee archivos KML, así que voy a convertir este archivo de Excel en un archivo KML y abrirlo con Google Earth!!  aquí hay 2 figuras que explican!!  la primera representa un ejemplo de archivo de Excel  http://www.hostingpics.net/viewer.php?id=154731Sanstitre.jpg  la segunda representa un ejemplo de representación de archivo KML en Google Earth  http://www.hostingpics.net/viewer.php?id=617527Capture.jpg

eriiic · Answer

de nada...  -- Nunca responderás a un mp no solicitado... Bueno, eso está hecho.

Darkjedi · Answer

Hola; Código a incluir en un módulo para generar KML a partir de Excel: OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'DECLARACIÓN DE VARIABLES Y CONSTANTES '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'primera fila activa Const LATITUDECOL = 26 'columna latitud Const LONGITUDECOL = 27 'columna longitud Const MARKERCOLORCOL = 30 'color marcador Const MARKERSIZECOL = 31 'tamaño marcador Const MARKERIMAGECOL = 29 'imagen marcador Const LABELCOLORCOL = 30 'color etiqueta Const LABELSIZECOL = 31 'tamaño etiqueta Const NAMECOL = 1 'visualización tipo en google map Const DESCRIPTIONCOL = 28 'visualización descripción en google map Const FOLDERCOL = 3 'creación archivo en google map ' modelo MARCADOR Const PLACEMARKTEMPLATE = _ "%CR%" & _ " %description%%CR%" & _ " %name%%CR%" & _ " %CR%" & _ " 1%CR%" & _ " %CR%" & _ " %longitude%, %latitude%, 0%CR%" & _ " %CR%" & _ "%CR%%CR%" ' " http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png%CR%" & _ 'modelo BOTÓN Const BUTTONTEMPLATE = _ " %CR%" & _ "%buttoncolortemplate%" & _ "%buttonscaletemplate%" & _ " http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png%CR%" & _ " %CR%" Const BUTTONCOLORTEMPLATE = " %buttoncolor%%CR%" Const BUTTONSCALETEMPLATE = " %buttonscale%%CR%" Const LABELTEMPLATE = " %labelcolortemplate%%labelscaletemplate%%CR%" Const LABELCOLORTEMPLATE = "ff%labelcolor%" Const LABELSCALETEMPLATE = "%labelscale%" 'variables salida 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 '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'CREACIÓN DEL ARCHIVO KML '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Mostrar el cuadro de diálogo Abrir y asignar el nombre de archivo seleccionado ' a la variable de cadena 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "¿Dónde deseas guardar tu archivo KML?", "Guardar") ' Si el usuario ha cancelado If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 ' hacer para todas las carpetas 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 '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCIÓN PARA CREAR ARCHIVO KML '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO CABECERA ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function StartKML() As String StartKML = "" & vbCrLf & _ "" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO FIN ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "" & vbCrLf & "" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO INICIO ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function StartFolder(folderName As String) As String StartFolder = " " & vbCrLf & _ " " & folderName & "" & vbCrLf & _ " 1" & vbCrLf & _ " 1" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO FIN ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " " & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO RELLENO 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 '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO MODELO KML '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable para modelo 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 '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO MODELO MARCADOR 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 '******************************************************************************************************* '******************************************************************************************************* 'ÚLTIMA FILA RELLENA DE LA TABLA FILTRACIÓN '******************************************************************************************************** '******************************************************************************************************** ' busca la última fila que contiene una dirección Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'dirección r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'código postal r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'municipio r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Devuelve una cadena de caracteres que contiene únicamente caracteres en la fuente ' que corresponden a los elementos de prueba. ' ' Ejemplo: RegExValidate("chris gemignani","aeiou") devuelve "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 Código a instalar en un módulo para el uso del portapapeles ' Este módulo define una función que te permite mantener datos de texto en el portapapeles. 'declaración funciones 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 'declaratación constantes Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'declaración variables Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Alocar la memoria global móvil. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Bloquear el bloque para obtener un puntero hacia esta memoria. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copia la cadena en esta memoria global. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Desbloquear la memoria. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "No se pudo desbloquear la ubicación de la memoria. Copia interrumpida. " GoTo OutOfHere2 End If ' Abrir el portapapeles para copiar los datos. If OpenClipboard(0&) = 0 Then MsgBox "No se pudo abrir el portapapeles. Copia interrumpida." Exit Function End If ' Borrar el portapapeles. x = EmptyClipboard() ' Copiar los datos en el portapapeles. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "No se pudo cerrar el portapapeles." End If End Function Código a instalar en un módulo para activar el enlace para google earth ' Este módulo define una función que te permite mantener datos de texto en el portapapeles. 'declaración funciones 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 'declaratación constantes Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'declaración variables Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Alocar la memoria global móvil. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Bloquear el bloque para obtener un puntero hacia esta memoria. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copia la cadena en esta memoria global. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Desbloquear la memoria. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "No se pudo desbloquear la ubicación de la memoria. Copia interrumpida. " GoTo OutOfHere2 End If ' Abrir el portapapeles para copiar los datos. If OpenClipboard(0&) = 0 Then MsgBox "No se pudo abrir el portapapeles. Copia interrumpida." Exit Function End If ' Borrar el portapapeles. x = EmptyClipboard() ' Copiar los datos en el portapapeles. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "No se pudo cerrar el portapapeles." End If End Function Referencias para comenzar en VBA de Excel: microsoft active X data object 2.8 library microsoft active X data object recordset 2.8 library microsoft xml v 6.0 A adaptar según tus hojas. y tus columnas que contengan la información deseada Cordialmente

Darkjedi · Answer

Hola; Código proveniente de A.SIMON y JUICE ANALYTIC y modificado para mi archivo Código a poner en un módulo para generar KML a partir de Excel: OPTION EXPLICIT '************************************************************************************************************* '************************************************************************************************************* 'DECLARACIÓN DE VARIABLES Y CONSTANTES '************************************************************************************************************* '************************************************************************************************************* Public folders As New Collection Const FIRSTDATAROW = 13 'primera línea activa Const LATITUDECOL = 26 'columna de latitud Const LONGITUDECOL = 27 'columna de longitud Const MARKERCOLORCOL = 30 'color del marcador Const MARKERSIZECOL = 31 'tamaño del marcador Const MARKERIMAGECOL = 29 'imagen del marcador Const LABELCOLORCOL = 30 'color de la etiqueta Const LABELSIZECOL = 31 'tamaño de la etiqueta Const NAMECOL = 1 'visualización del tipo en google map Const DESCRIPTIONCOL = 28 'visualización de la descripción en google map Const FOLDERCOL = 3 'creación de archivo en google map ' modelo MARCADOR Const PLACEMARKTEMPLATE = _ "%CR%" & _ " %description%%CR%" & _ " %name%%CR%" & _ " %CR%" & _ " 1%CR%" & _ " %CR%" & _ " %longitude%, %latitude%, 0%CR%" & _ " %CR%" & _ "%CR%%CR%" ' " http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png%CR%" & _ 'modelo BOTÓN Const BUTTONTEMPLATE = _ " %CR%" & _ "%buttoncolortemplate%" & _ "%buttonscaletemplate%" & _ " http://maps.google.com/mapfiles/kml/pal4/icon%buttonimage%.png%CR%" & _ " %CR%" Const BUTTONCOLORTEMPLATE = " %buttoncolor%%CR%" Const BUTTONSCALETEMPLATE = " %buttonscale%%CR%" Const LABELTEMPLATE = " %labelcolortemplate%%labelscaletemplate%%CR%" Const LABELCOLORTEMPLATE = "ff%labelcolor%" Const LABELSCALETEMPLATE = "%labelscale%" 'variables salida 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 '************************************************************************************************************************************************** '************************************************************************************************************************************************** 'CREACIÓN DEL ARCHIVO KML '************************************************************************************************************************************************** '************************************************************************************************************************************************** Sub OutputKML() 'Mostrar el cuadro de diálogo Guardar como y asignar el nombre de archivo seleccionado ' a la variable de cadena 'sFileName' sFileName = Application.GetSaveAsFilename("test.kml", "KML Files (*.kml),*.kml", 1, "¿Dónde quieres guardar tu archivo KML?", "Guardar") ' Si el usuario ha cancelado If sFileName = "False" Then Exit Sub 'Call ConvertirNumerique Open CStr(sFileName) For Output As #1 'por hacer para todas las carpetas 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 '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* 'FUNCIÓN PARA CREACIÓN DEL ARCHIVO KML '********************************************************************************************************************************************************************************* '********************************************************************************************************************************************************************************* '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO ENCABEZADO ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function StartKML() As String StartKML = "" & vbCrLf & _ "" & vbCrLf & "" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO FIN ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function EndKML() As String EndKML = "" & vbCrLf & "" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO INICIO ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function StartFolder(folderName As String) As String StartFolder = " " & vbCrLf & _ " " & folderName & "" & vbCrLf & _ " 1" & vbCrLf & _ " 1" & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO FIN ARCHIVO KML '******************************************************************************************************** '******************************************************************************************************** Function EndFolder() As String EndFolder = " " & vbCrLf End Function '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO RELLENO 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 '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO MODELO KML '******************************************************************************************************** '******************************************************************************************************** Function template(templatestr As String, replacements As Collection) As String 'variable para modelo 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 '******************************************************************************************************* '******************************************************************************************************* 'ARCHIVO MODELO MARCADOR 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 marcador 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 '******************************************************************************************************* '******************************************************************************************************* 'ÚLTIMA LÍNEA RELLENA DE LA TABLA FILTRACIÓN '******************************************************************************************************** '******************************************************************************************************** ' busca la última línea que contiene una dirección Function LastDataRow() As Integer Dim r As Integer activecelladdr = ActiveCell.Address Range("i65536").End(xlUp).Select 'dirección r = ActiveCell.Row() Range("j65536").End(xlUp).Select 'código postal r = max(r, ActiveCell.Row()) Range("k65536").End(xlUp).Select 'comuna r = max(r, ActiveCell.Row()) Range(activecelladdr).Select LastDataRow = r End Function ' Devuelve una cadena de caracteres que solo contiene caracteres en la fuente ' que corresponden a los elementos de prueba. ' ' Ejemplo: RegExValidate("chris gemignani","aeiou") devuelve "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 Código a instalar en un módulo para el uso del portapapeles ' Este módulo define una función que te permite mantener datos textuales en el portapapeles. 'declaración funciones 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 'declaración constantes Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'declaración variables Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Asigna la memoria global móvil. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Bloquea el bloque para obtener un puntero hacia esta memoria. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copia la cadena en esta memoria global. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Desbloquea la memoria. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "No se pudo desbloquear la ubicación de la memoria. Copia interrumpida. " GoTo OutOfHere2 End If ' Abre el portapapeles para copiar los datos. If OpenClipboard(0&) = 0 Then MsgBox "No se pudo abrir el Portapapeles. Copia interrumpida." Exit Function End If ' Limpia el portapapeles. x = EmptyClipboard() ' Copia los datos en el portapapeles. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "No se pudo cerrar el portapapeles." End If End Function Código a instalar en un módulo para activar el enlace para Google Earth ' Este módulo define una función que te permite mantener datos textuales en el portapapeles. 'declaración funciones 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 'declaración constantes Public Const GHND = &H42 Public Const CF_TEXT = 1 Public Const MAXSIZE = 4096 'declaración variables Dim hGlobalMemory As Long Dim lpGlobalMemory As Long Dim hClipMemory As Long Dim x As Long Function ClipBoard_SetData(MyString As String) ' Asigna la memoria global móvil. hGlobalMemory = GlobalAlloc(GHND, Len(MyString) + 1) ' Bloquea el bloque para obtener un puntero hacia esta memoria. lpGlobalMemory = GlobalLock(hGlobalMemory) ' Copia la cadena en esta memoria global. lpGlobalMemory = lstrcpy(lpGlobalMemory, MyString) ' Desbloquea la memoria. If GlobalUnlock(hGlobalMemory) <> 0 Then MsgBox "No se pudo desbloquear la ubicación de la memoria. Copia interrumpida. " GoTo OutOfHere2 End If ' Abre el portapapeles para copiar los datos. If OpenClipboard(0&) = 0 Then MsgBox "No se pudo abrir el Portapapeles. Copia interrumpida." Exit Function End If ' Limpia el portapapeles. x = EmptyClipboard() ' Copia los datos en el portapapeles. hClipMemory = SetClipboardData(CF_TEXT, hGlobalMemory) OutOfHere2: If CloseClipboard() = 0 Then MsgBox "No se pudo cerrar el portapapeles." End If End Function Referencias para empezar en VBA de Excel: microsoft active X data object 2.8 library microsoft active X data object recordset 2.8 library microsoft xml v 6.0 A adaptar según tus hojas. Cordialmente. Oups duplicado.... lo siento

Convertir archivo excel a archivo kml

6 respuestas

Problema de grabación y lectura de archivos jpg

Fusionar particiones

Conexión de audio de pc, enchufes jack para cadena hi-fi

Conducir a 110 km/h en autopista: ahorro de combustible y ganancia de seguridad

Problema de texturas en enshrouded

Meta renuncia a usar tus publicaciones de instagram para crear contenido ia

Dispositivos a renovar

Aplicación samsung smart switch

Impresora canon pixma no detectada por livebox 7

Mp3 con radio antiguo