Option Explicit

Private Declare Function MultiByteToWideChar Lib "kernel32.dll" (ByVal CodePage As Long, _
    ByVal dwFlags As Long, ByVal lpMultiByteStr As String, ByVal cchMultiByte As Long, _
    ByVal lpWideCharStr As Long, ByVal cchWideChar As Long) As Long
Private Declare Function WideCharToMultiByte Lib "kernel32.dll" (ByVal CodePage As Long, _
    ByVal dwFlags As Long, ByVal lpWideCharStr As Long, ByVal cchWideChar As Long, _
    ByVal lpMultiByteStr As Long, ByVal cchMultiByte As Long, _
    ByVal lpDefaultChar As Long, ByVal lpUsedDefaultChar As Long) As Long

Public Function EncodeUTF8(strSrc As String) As String
    Dim nLen As Long
    Dim strDst As String
    Dim strRet As String
    Dim nRet As Long
    Dim p As Long

    nLen = Len(strSrc)
    strDst = String(nLen *  2 , Chr( 0 ))
    strRet = String(nLen *  2 , Chr( 0 ))
    p = StrPtr(strDst)
    nRet = MultiByteToWideChar( 1251 , &H1, strSrc, nLen, p, nLen)
    nRet = WideCharToMultiByte( 65001 ,  0 , p, nRet, StrPtr(strRet), nLen *  2 , ByVal  0 ,  0 )
    EncodeUTF8 = Left$(StrConv(strRet, vbUnicode), nRet)
End Function

Function UTF8_16(s)
    UTF8_16 = ""
    Dim i, j, j2, ch, k1, k2, k3, m
    i =  1 
    Do While i <= Len(s)
        ch = Mid(s, i,  1 )
        j = CLng(Asc(ch))
        If j >=  128  Then
            If j <  224  Then
                '2 байта
                k1 = j Mod  32 
                i = i +  1 
                ch = Mid(s, i,  1 )
                j2 = CLng(Asc(ch))
                k2 = j2 Mod  64 
                'ChrW - символ по UTF-16 значению
                UTF8_16 = UTF8_16 & ChrW(k2 + k1 *  64 )
            Else
                '3 байта
                k1 = j Mod  16 
                i = i +  1 
                ch = Mid(s, i,  1 )
                j2 = CLng(Asc(ch))
                k2 = j2 Mod  64 
                i = i +  1 
                ch = Mid(s, i,  1 )
                j2 = CLng(Asc(ch))
                k3 = j2 Mod  64 
                UTF8_16 = UTF8_16 & ChrW(k3 + (k2 + k1 *  64 ) *  64 )
            End If
        Else
            UTF8_16 = UTF8_16 & ch
        End If
        i = i +  1 
    Loop
End Function


'/// Функция кодирования недопустимых символов в URL.
    Public Function EncodeURIcomponent(SourceString)
        Dim i, C, Out
        For i =  1  To Len(SourceString)
          C = Asc(Mid(SourceString, i,  1 ))
          '/// Пробелы заменяем на плюс
          If C =  32  Then
            EncodeURIcomponent = EncodeURIcomponent + "+"
            '/// Запрещённые символы заменяем на "%" и HEX значение от кода символа
          ElseIf (C <  48  Or C >  126 ) Or (C >  56  And C <=  64 ) Then
            EncodeURIcomponent = EncodeURIcomponent + "%" + Hex(C)
          Else
          '/// Разрещённые символы добавляем как есть
            EncodeURIcomponent = EncodeURIcomponent + Chr(C)
          End If
        Next
    End Function
Sub xfh()
Dim i As Long, s As String, s1 As String, s2 As String
s = "Днепропетровск,Карла Маркса,35"
s2 = EncodeUTF8(s)
For i =  1  To Len(s)
    If Asc(Mid(s, i,  1 )) >  127  Then
        s1 = s1 & "%" & CStr(Hex(Asc((Mid(s2, i,  1 )))))
    Else
        s1 = s1 & Mid(s, i,  1 )
    End If
Next i
Debug.Print s1
s1 = URLEncode(s)
End Sub

 Function URLEncode(Data)
        Dim CharPosition, CharCode
        For CharPosition =  1  To Len(Data)
            CharCode = Asc(Mid(Data, CharPosition,  1 ))
            If CharCode =  32  Then
                URLEncode = URLEncode + "%20"
            ElseIf (CharCode <  48  Or CharCode >  126 ) Or (CharCode >  56  And CharCode <=  64 ) Then
                URLEncode = URLEncode + "%" + Right("0" & Hex(CharCode),  2 )
            Else
                URLEncode = URLEncode + Chr(CharCode)
            End If
        Next
    End Function

Sub dr()
Dim ie As Object, r As Worksheet, arr() As String
Dim MyStr As String
Dim i As Long
Set r = ThisWorkbook.Sheets("Kiev")
Set ie = CreateObject("InternetExplorer.Application")
For i =  1  To  494 
    'ie.Navigate 
"http://maps.google.com/maps/geo?q=%D0%94%D0%BD%D0%B5%D0%BF%D1%80%D0%BE%D0%BF%D0%B5%D1%82%D1%80%D0%BE%D0%B2%D1%81%D0%BA,%D0%9A%D0%B0%D1%80%D0%BB%D0%B0%20%D0%9C%D0%B0%D1%80%D0%BA%D1%81%D0%B0,35&output=csv"
    ie.Navigate "http://maps.google.com/maps/geo?q=" & r.Cells(i,  9 ).Value & "&output=csv"
    While ie.busy
      DoEvents
    Wend
    'MyStr = ie.Document.body.innerHTML
'    Debug.Print ie.document.body.innertext
    arr = Split(ie.document.body.innertext, ",")
    r.Cells(i,  10 ).Value = arr( 0 )
    r.Cells(i,  11 ).Value = arr( 1 )
    r.Cells(i,  12 ).Value = arr( 2 )
    r.Cells(i,  13 ).Value = arr( 3 )
Next i
Set r = ThisWorkbook.Sheets("Ukraine")
For i =  1  To  2071 
    'ie.Navigate 
"http://maps.google.com/maps/geo?q=%D0%94%D0%BD%D0%B5%D0%BF%D1%80%D0%BE%D0%BF%D0%B5%D1%82%D1%80%D0%BE%D0%B2%D1%81%D0%BA,%D0%A7%D0%BA%D0%B0%D0%BB%D0%BE%D0%B2%D0%B0,27&output=csv"
    ie.Navigate "http://maps.google.com/maps/geo?q=" & r.Cells(i,  9 ).Value & "&output=csv"
    While ie.busy
      DoEvents
    Wend
    'MyStr = ie.Document.body.innerHTML
'    Debug.Print ie.document.body.innertext
    arr = Split(ie.document.body.innertext, ",")
    r.Cells(i,  10 ).Value = arr( 0 )
    r.Cells(i,  11 ).Value = arr( 1 )
    r.Cells(i,  12 ).Value = arr( 2 )
    r.Cells(i,  13 ).Value = arr( 3 )
Next i

Set r = Nothing
ie.Quit
Set ie = Nothing
End Sub