Budte pozdraveni,
resim ted takovy neprijemny orisek. Delam si jeden mensi projekt a nasel jsem docela pekne vytvorene "knihovny" na netu, ale bohuzel jsou ve VB a ten ja neumim. Lecos jsem si prelozil sam, ale jsou tam prikazy, ktere proste nevim jak prelozit. Moje znalosti C#az tak daleko... Myslite, ze by jste mi s tim mohli pomoc? Pokud to tedy nekdo z vas ovlada...
Pokud to sem nepatri, tak se omlouvam.
Function fceGetAddressInfo(sAdresa, sLokalita)
Dim oHTTP As New MSXML2.XMLHTTP ' objekt HTTP
Dim oKML As New DOMDocument ' objekt XML
Dim oNode As IXMLDOMNode
Dim sQuery, sURL, sContent
Dim aResult, i As Integer
Dim sPref
sAdresa = Trim(sAdresa) ' zbavíme se mezer před a za
sLokalita = Trim(sLokalita)
sQuery = sAdresa & IIf(Len(sLokalita) > 0, "," & sLokalita, "")
sQuery = URLEncode(sQuery) ' korekce URL (diakritika)
sURL = "http://maps.google.cz/maps/geo?q=" & sQuery & "&gl=cs&hl=cs&output=xml"
' výsledek dotazu v xml
With oHTTP
.Open "GET", sURL, False
.send
sContent = .responseText ' do proměnné sContent načteme výsledek v XML
End With
' nyní obsah xml budeme parsovat za pomocí MSXML parser
With oKML ' objekt DOM
.resolveExternals = False ' externích entity nenačítáme
.LoadXML (sContent) ' načtení XML z proměnné
End With
'Debug.Print sContent ' obsah proměné vypíšeme do okna Immediate (VBA editor: CTRL + G)
On Error GoTo ErrorHandler ' některé tagy nemusí existovat, proto budeme chyby zachytávat
' ověření Status Code (zajímá nás pouze kód 200)
sResult = fceGetCodeResult(oKML.DocumentElement.SelectSingleNode("//code").Text)
If sResult <> 1 Then
fceGetAddressInfo = "ERR: " & sResult
Exit Function
End If
' OK, vyhodnotíme
i = 0
aResult = 0
sPref = "AddressDetails//Country//"
sRegAddres = fceGetRegular(sAdresa, "^(.*[^0-9]+) ") 'pouze název ulice bez čísla
For Each oNode In oKML.SelectNodes("//Placemark") 'projedeme záznam po záznamu
With oNode
sAccuracy = .SelectSingleNode("AddressDetails").Attributes.getNamedItem("Accuracy").Text
If sAccuracy = 8 Then 'zajímá nás pouze přesnost "8"
i = i + 1
aTmp = Split(.SelectSingleNode("Point//coordinates").Text, ",")
sLat = Val(aTmp(1))
sLon = Val(aTmp(0))
aTmp = Split(.SelectSingleNode("address").Text, ",")
sAddress = aTmp(0)
sInfAdr = Trim(aTmp(1))
If i = 1 Then
ReDim aResult(9, 1)
Else
ReDim Preserve aResult(9, i)
End If
'výsledek uložíme do pole
aResult(0, i - 1) = IIf(LCase(fceGetRegular(sAddress, _
"^(.*[^0-9]+) ")) = LCase(sRegAddres), _
IIf(LCase(sAdresa) = LCase(sAddress), 2, 1), 0) '(ne)shoda názvu ul.
aResult(1, i - 1) = sLat
aResult(2, i - 1) = sLon
aResult(3, i - 1) = sAddress
aResult(4, i - 1) = .SelectSingleNode(sPref & "Locality//LocalityName").Text
aResult(5, i - 1) = sInfAdr
aResult(6, i - 1) = .SelectSingleNode(sPref & "Locality//DependentLocality//DependentLocalityName").Text
aResult(7, i - 1) = .SelectSingleNode(sPref & "Locality//PostalCode//PostalCodeNumber").Text
aResult(8, i - 1) = .SelectSingleNode(sPref & "CountryName").Text
End If
End With
Next
Fin:
On Error GoTo 0
Set oNode = Nothing
Set objHTTP = Nothing
Set oKML = Nothing
fceGetAddressInfo = aResult 'volající proceduře vrátíme námi vytvořené pole aResult
Exit Function ' konec
ErrorHandler: 'vyhodnocení chyby
Select Case Err.Number
Case 91
Resume Next 'chybí požadovaný element (my to však ignorujeme)
Case Else
MsgBox "Lituji, vyskytla se chyba!" & vbCrLf & vbCrLf & _
"Chyba č.:" & vbTab & Err.Number & vbCrLf & _
"Popis: " & vbTab & Err.Description & vbCrLf & _
"Kontext:" & vbTab & Err.HelpContext, vbCritical, "Chyba"
Err.Clear
GoTo Fin 'skok na návěstí Fin:
End Select
End Function
'--------------------------------------
' funkce vyhodnotí Status Code
'--------------------------------------
Function fceGetCodeResult(sCode) As String
Dim sResult
Select Case sCode
Case 200
sResult = 1
Case 500
sResult = "Chyba serveru."
Case 601
sResult = "Adresa nebyla zadána nebo byla chybně uvedena."
Case 602
sResult = "Nepodařilo se najít georeferenci k uvedené adrese."
Case 603
sResult = "Tato adresa je legislativně chráněna a nemůže být zveřejněna."
Case 610
sResult = "Chybný klíč API."
Case 620
sResult = "Překročen povolený limit hledání pro tento API klíč"
Case Else
sResult = "Neznámý kód."
End Select
fceGetCodeResult = sResult
End Function
'--------------------------------------
' RegExp
'--------------------------------------
Function fceGetRegular(sText, sPattern)
Dim oRegExp As Object, sRet
Set oRegExp = CreateObject("VbScript.RegExp")
With oRegExp
.Pattern = sPattern
.Global = True
.IgnoreCase = True
End With
Set matches = oRegExp.Execute(sText)
For Each Match In matches
sRet = Trim(Match.Value)
Next
fceGetRegular = sRet
End Function
Public Function URLEncode(ByVal StringToEncode As String) As String
'ZDROJ: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_23770838.html
'by danaseaman, alexspi
Dim i As Integer, iAsc As Long, sTemp As String
Dim ByteArrayToEncode() As Byte
ByteArrayToEncode = ADO_EncodeUTF8(StringToEncode)
For i = 0 To UBound(ByteArrayToEncode)
iAsc = ByteArrayToEncode(i)
Select Case iAsc
Case 32 'space
sTemp = "+"
Case 48 To 57, 65 To 90, 97 To 122
sTemp = Chr(ByteArrayToEncode(i))
Case Else
'Debug.Print iAsc
sTemp = "%" & Hex(iAsc)
End Select
URLEncode = URLEncode & sTemp
Next
End Function
Public Function ADO_EncodeUTF8(ByVal strUTF16 As String) As Byte()
'ZDROJ: http://www.experts-exchange.com/Programming/Languages/Visual_Basic/Q_23770838.html
'by danaseaman, alexspi
'Purpose: UTF16 to UTF8 using ADO
Dim objStream As Object, data() As Byte
Const adTypeBinary As Long = 1
Const adTypeText As Long = 2
Const adModeReadWrite As Long = 3
Set objStream = CreateObject("ADODB.Stream")
objStream.Charset = "utf-8"
objStream.Mode = adModeReadWrite
objStream.Type = adTypeText
objStream.Open
objStream.WriteText strUTF16
objStream.flush
objStream.Position = 0
objStream.Type = adTypeBinary
objStream.Read 3 ' skip BOM
data = objStream.Read()
objStream.Close
ADO_EncodeUTF8 = data
End Function
