Public Function cpMap(ByVal Direc As String, ByVal POB As String) As String
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-conocer-codigo-postal-y-coordenadas-con-la-api-de-google-maps
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : cpMap
' Autor original : Luis Viadel
' Fecha : 13/01/2020
' Propósito : Búsqueda de códigos postales y coordenadas en Google Maps
' Retorno : Devuelve las coordenadas de la posición y el C.P.
' Argumento/s : La sintaxis del procedimiento o función consta del siguiente argumento:
' Parte Modo Descripción
'-----------------------------------------------------------------------------------------------------------------------------------------------
' direc Obligatorio Dirección a buscar
' pob Obligatorio Población
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Referencia : Microsoft XML, v6.0
' Mas información : https://mapsplatform.google.com/
' Importante : deberemos crear una cuenta de desarrollador para obtener una APIKey
'-----------------------------------------------------------------------------------------------------------------------------------------------
'Test: : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
' portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese y pulsar F5 para ver su funcionamiento.
'
'Sub cmpa_test()
'Dim txtzip as string
'Dim direc as string, pob as string
'
'direc=""
'pob=""
'txtzip = cpMap(Direc, POB)
'Debug.print txtZip
'End Sub
'-----------------------------------------------------------------------------------------------------------------------------------------------
Dim objXMLHTTP As MSXML2.XMLHTTP60
Dim sURL As String, datos As String, Str1 As String, subdata As String, CP As String
Dim J As Integer, I As Integer, intWhere As Integer
Dim ArrayRes
On Error Resume Next
Set objXMLHTTP = New MSXML2.XMLHTTP60
sURL = "https://maps.googleapis.com/maps/api/place/textsearch/json?query="
sURL = sURL & UTF8(Direc) & "%20" & UTF8(POB)
sURL = sURL & "&key=" & APIKey
With objXMLHTTP
.Open "GET", sURL, False
.setRequestHeader "Content-Type", "application/json"
.Send ("")
End With
Str1 = objXMLHTTP.responseText
Debug.Print Str1
Set objXMLHTTP = Nothing
ArrayRes = Split(Str1, "formatted_address")
J = UBound(ArrayRes) - LBound(ArrayRes) + 1
For I = 1 To 1
subdata = ArrayRes(I)
datos = Right(subdata, Len(subdata) - 5)
intWhere = InStr(datos, "geometry")
datos = Left(datos, intWhere - 1)
intWhere = InStr(datos, ",") 'Calle
datos = Right(datos, Len(datos) - intWhere - 1)
intWhere = InStr(datos, ",")
datos = Right(datos, Len(datos) - intWhere - 1)
CP = Left(datos, 5)
Next I
ArrayRes = Split(Str1, "lat")
J = UBound(ArrayRes) - LBound(ArrayRes) + 1
For I = 1 To 1
subdata = ArrayRes(I)
datos = Right(subdata, Len(subdata) - 4)
intWhere = InStr(datos, ",")
latitud = Left(datos, intWhere - 1)
latitud = Trim(latitud)
Next I
ArrayRes = Split(Str1, "lng")
J = UBound(ArrayRes) - LBound(ArrayRes) + 1
For I = 1 To 1
subdata = ArrayRes(I)
datos = Right(subdata, Len(subdata) - 4)
intWhere = InStr(datos, "}")
longitud = Left(datos, intWhere - 1)
longitud = Trim(longitud)
Next I
cpMap = CP & "," & latitud & "," & longitud
End Function
Function UTF8(strTexto As String) As String
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Fuente : https://access-global.net/vba-conocer-codigo-postal-y-coordenadas-con-la-api-de-google-maps
'-----------------------------------------------------------------------------------------------------------------------------------------------
' Título : UTF8
' Autor original : desconocido
' Fecha : desconocida
' Propósito : modificar cadenas de texto para que sean legibles por un navegador web
' Retorno : Devuelve la cadena transformada
' Argumento/s : La sintaxis del procedimiento o función consta del siguiente argumento:
' Parte Modo Descripción
'-----------------------------------------------------------------------------------------------------------------------------------------------
' strTexto Obligatorio Cadena que queremos trnsformar
'-----------------------------------------------------------------------------------------------------------------------------------------------
'Test: : Para adaptar este código en tu aplicación puedes basarte en este procedimiento test. Copiar el bloque siguiente al
' portapapeles y pega en el editor de VBA. Descomentar la línea que nos interese y pulsar F5 para ver su funcionamiento.
'
'Sub cmpa_test()
'Dim strtxto as string
'
'strtxto=""
'strtxto = UTF8(strtxto)
'
'End Sub
'-----------------------------------------------------------------------------------------------------------------------------------------------
strTexto = Replace(strTexto, " ", "%20")
strTexto = Replace(strTexto, "Ñ", "%C3%91")
strTexto = Replace(strTexto, "ñ", "%C3%B1")
strTexto = Replace(strTexto, "á", "%C3%A1")
strTexto = Replace(strTexto, "à", "%C3%A0")
strTexto = Replace(strTexto, "â", "%C3%A2")
strTexto = Replace(strTexto, "ã", "%C3%A3")
strTexto = Replace(strTexto, "ä", "%C3%A4")
strTexto = Replace(strTexto, "å", "%C3%A5")
strTexto = Replace(strTexto, "è", "%C3%A8")
strTexto = Replace(strTexto, "é", "%C3%A9")
strTexto = Replace(strTexto, "ê", "%C3%AA")
strTexto = Replace(strTexto, "ë", "%C3%AB")
strTexto = Replace(strTexto, "ì", "%C3%AC")
strTexto = Replace(strTexto, "í", "%C3%AD")
strTexto = Replace(strTexto, "î", "%C3%AE")
strTexto = Replace(strTexto, "ï", "%C3%AF")
strTexto = Replace(strTexto, "ð", "%C3%B0")
strTexto = Replace(strTexto, "ò", "%C3%B2")
strTexto = Replace(strTexto, "ó", "%C3%B3")
strTexto = Replace(strTexto, "ô", "%C3%B4")
strTexto = Replace(strTexto, "õ", "%C3%B5")
strTexto = Replace(strTexto, "ö", "%C3%B6")
strTexto = Replace(strTexto, "ù", "%C3%B9")
strTexto = Replace(strTexto, "ú", "%C3%BA")
strTexto = Replace(strTexto, "û", "%C3%BB")
strTexto = Replace(strTexto, "ü", "%C3%BC")
strTexto = Replace(strTexto, ",", "%2C")
strTexto = Replace(strTexto, "ý", "%C3%BD")
strTexto = Replace(strTexto, "þ", "%C3%BE")
strTexto = Replace(strTexto, "ÿ", "%C3%BF")
strTexto = Replace(strTexto, "÷", "%C3%B7")
UTF8 = strTexto
End Function
