在一个excel里面直接批量从谷歌地图抓取经纬度（vba部分）

'http://apps.hi.baidu.com/share/detail/6440301


Function Uri(strText As String)
'Sub Uri()
    Dim s As Integer
    Dim ii As String
    Dim tmp As String


    'strText = "你1 你"
    'uri = ""
    
    For i = 1 To Len(strText)
        temp = Asc(Mid$(strText, i, 1))
        If temp > 255 Or temp < 0 Then
            tmp = Hex(temp)
            Uri = Uri & "%" & Left(tmp, 2) & "%" & Right(tmp, 2)
        Else
            Uri = Uri & Mid$(strText, i, 1)
        End If
    Next i
    Uri = Replace(Uri, " ", "%20")
End Function
Function toUTF8(szInput)
    Dim wch, uch, szRet
    Dim x
    Dim nAsc, nAsc2, nAsc3
    '如果输入参数为空，则退出函数
    If szInput = "" Then
        toUTF8 = szInput
        Exit Function
    End If
    '开始转换
     For x = 1 To Len(szInput)
        '利用mid函数分拆GB编码文字
        wch = Mid(szInput, x, 1)
        '利用ascW函数返回每一个GB编码文字的Unicode字符代码
        '注：asc函数返回的是ANSI 字符代码，注意区别
        nAsc = AscW(wch)
        If nAsc < 0 Then nAsc = nAsc + 65536
    
        If (nAsc And &HFF80) = 0 Then
            szRet = szRet & wch
        Else
            If (nAsc And &HF000) = 0 Then
                uch = "%" & Hex(((nAsc \ 2 ^ 6)) Or &HC0) & Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            Else
               'GB编码文字的Unicode字符代码在0800 - FFFF之间采用三字节模版
                uch = "%" & Hex((nAsc \ 2 ^ 12) Or &HE0) & "%" & _
                            Hex((nAsc \ 2 ^ 6) And &H3F Or &H80) & "%" & _
                            Hex(nAsc And &H3F Or &H80)
                szRet = szRet & uch
            End If
        End If
    Next
        
    toUTF8 = szRet
End Function
Sub Macro2()
'
' Macro2 Macro
'
' 快捷键: Ctrl+t
'
    Dim iRows, iRowBeg As Integer
    Dim strCxt As String
    Dim strHtml As String
    Dim strSearch As String
    Dim strUri As String
    Dim HttpReq As Object
    Dim strRes As String
    Dim iReDown, iHasReDown As Integer
    Dim strSrcCol, strResCol As String
    
    iReDown = 5  '如果下载失败重复尝试的次数
    iHasReDown = 0 '已经重复下载了的次数
    iRowBeg = 1 '要下载的开始行
    iRows = 100 '要下载的截止行
    strSrcCol = "A" '从哪一列读取数据
    strResCol = "D" '在哪一列存储结果
    
    Set HttpReq = CreateObject("MSXML2.XMLHTTP.3.0")
    For counter = 1 To iRows
        Debug.Print counter & "/" & iRows
        Sheet1.Select
        strSearch = Range(strSrcCol & counter) & " 北京"
        strSearch = toUTF8(strSearch)
        strSearch = Uri(strSearch)
        strHtml = "http://maps.google.cn/maps/geo?q=" & strSearch & "&output=csv&oe=utf8&sensor=true_or_false&key=ABQIAAAAqaGKijD7euSpqDeVsNA85xTT3OL8VXjPlPTFW7n7OgOFwXoSnxT7IP1pHznaiGwWMvsEq_SkxvESLw"
        'strHtml = "http://maps.google.com.hk/maps/geo?q=014%E4%B8%AD%E5%BF%83%20%E6%B4%9B%E9%98%B3%E5%B8%82&output=csv&oe=utf8&sensor=true_or_false&key=ABQIAAAAqaGKijD7euSpqDeVsNA85xTT3OL8VXjPlPTFW7n7OgOFwXoSnxT7IP1pHznaiGwWMvsEq_SkxvESLw"
        'strHtml = "http://maps.google.cn/maps/geo?q=%E4%BA%94%E5%8F%B0%E5%B1%B1%20%E5%8C%97%E4%BA%AC&output=csv&oe=utf8&sensor=true_or_false&key=ABQIAAAAqaGKijD7euSpqDeVsNA85xTT3OL8VXjPlPTFW7n7OgOFwXoSnxT7IP1pHznaiGwWMvsEq_SkxvESLw/"
        'strHtml = "http://www.baidu.com"
        'Range("E" & counter) = strHtml
        HttpReq.Open "GET", strHtml, False
        HttpReq.send
        'HttpReq.getAllResponseHeaders
        'MsgBox HttpReq
        strRes = HttpReq.responseText
        Range(strResCol & counter) = strRes
        If ",0,0" = Right(strRes, 4) Then
            '结果错误
            If iHasReDown >= iReDown - 1 Then
                '错误次数超过
                iHasReDown = 0
            Else
                iHasReDown = iHasReDown + 1
                counter = counter - 1
            End If
        Else
            iHasReDown = 0
        End If
    Next
End Sub