VBA Excel OneClickSearchingLocationInfo v.15 Télécharger - VBA Excel OneClickSearchingLocationInfo v.15 Code source Télécharger

VBA-ENCEL-ONEClickSearchingLocationInfo-V.15

Vérification par lots en un clic des cartes Baidu et des cartes Bing Sub BaiduMap ()

 Dim url, html, js
Dim i%, j%

url = ""

Set html = CreateObject("htmlfile")

Set js = CreateObject("scriptcontrol")

js.Language = "jscript"

'----------------------------- quyu = application.inputbox ("Pour éviter les restrictions de requête du site Web, essayez de ne pas dépasser 500 requêtes par requête, et une requête fréquente excessive peut ne pas renvoyer les résultats" et Chr (13) et Chr (13) et "Veuillez sélectionner la zone de cellule où les informations d'adresse à interrogation", "s'il vous plaît sélectionnez les informations d'adresse pour être questiones", "" ", Type: = 8).

 Range(quyu).Select

s = Range(quyu).Cells(1, 1).Row
t = Range(quyu).Rows.Count + s - 1
    
If s = False Then Exit Sub

If t = False Then Exit Sub
If t < s Then MsgBox "结束行号不能小行开始行号！": Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False

'-----------------------------------------------------------------------------------------------------------------------------

 For s = s To t

    With CreateObject("msxml2.xmlhttp")

        url = "https://map.baidu.com/?newmap=1&reqflag=pcmap&biz=1&from=webmap&da_par=baidu&pcevaname=pc4.1&qt=s&da_src=searchBox.button&wd="

'--------------------

        Str1 = Cells(s, 1).Value
        
        With CreateObject("scriptcontrol")
        .Language = "javascript"
        Str2 = .eval("encodeURIComponent('" & Str1 & "');")
        
        End With
                    
        url = url & Str2
        
        url = url & "&c=131&src=0&wd2=&pn=0&sug=0&l=12&b=(12575228.9212,2644035.4608000005;12618301.45,2687971.5992)&from=webmap&biz_forward={%22scaler%22:1,%22styles%22:%22pl%22}&sug_forward=&auth=%3DO3RbGcH7yfV4Jg431bVcM8K7gL%40xzVeuxHBBxBzLEEtBnlQADZZz1GgvPUDZYOYIZuVt1cv3uVtPWv3GuLt8BnlQcWlADZZZZZZZZZzWvPYuxt8zv7u%40ZPuLtjADzfiKKvAuexZFTHrwzzvC00dE7&device_ratio=1&tn=B_NORMAL_MAP&nn=0&u_loc=12596793,2623529&ie=utf-8&t=1533132645275"

        .Open "get", url, False

        .send

        js.addcode ("suwenkai = " & .responsetext)

        slen = js.eval("suwenkai.content.length") - 2


        On Error Resume Next
        
       For i = 0 To slen


            Cells(s, 2) = js.eval("suwenkai.content[" & i & "].name")

            Cells(s, 3) = js.eval("suwenkai.content[" & i & "].addr")

            Cells(s, 4) = js.eval("suwenkai.content[" & i & "].tel")
            
        Next
        

    End With
    
Next

Sub-Sub

Sub bingmap ()

 Dim url, html, js
Dim i%, j%

url = ""

Set html = CreateObject("htmlfile")

Set js = CreateObject("scriptcontrol")

js.Language = "jscript"

 Range(quyu).Select

s = Range(quyu).Cells(1, 1).Row
t = Range(quyu).Rows.Count + s - 1
    
If s = False Then Exit Sub

If t = False Then Exit Sub
If t < s Then MsgBox "结束行号不能小行开始行号！": Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False

'-----------------------------------------------------------------------------------------------------------------------------

 For s = s To t

    With CreateObject("msxml2.xmlhttp")

        url = "https://cn.bing.com/maps/overlay?q="

'--------------------

        Str1 = Cells(s, 1).Value
        
        With CreateObject("scriptcontrol")
        .Language = "javascript"
        Str2 = .eval("encodeURIComponent('" & Str1 & "');")
        
        End With
                    
        url = url & Str2
        
        url = url & "&filters=direction_partner%3A%22maps%22%20tid%3A%22FBEA96CC6B2A40989C2A6CA5C2D47306%22&mapcardtitle=&appid=E18E19EF-764F-41A9-B53E-6E98AE519695&p1=[AplusAnswer]&count=20&ecount=20&first=0&efirst=1&localMapView=30.271807645114265,120.13721036911012,30.26011339339155,120.14394807815553#"
        
        
        
        .Open "get", url, False
        .setRequestHeader "User-Agent", "Mozilla/5.0 (Windows NT 10.0; Win64; x64) AppleWebKit/537.36 (KHTML, like Gecko) Chrome/68.0.3440.84 Safari/537.36"
        
        .send
        
        text0 = .responsetext
          
        If InStr(1, text0, "searchSuggestionTitle") = 0 Then
        
        On Error Resume Next
        
                    
        text1 = Split(.responsetext, "class=" & Chr(34) & "b_address" & Chr(34) & ">")(1)
        text2 = Split(text1, "</span></li><li><span class=" & Chr(34) & "cbl b_lower" & Chr(34) & ">Phone:</span>")(0)
        
        text3 = Split(text1, "</span></li><li><span class=" & Chr(34) & "cbl b_lower" & Chr(34) & ">Phone:</span>")(1)
        text4 = Split(text3, "</li><li><span class=" & Chr(34) & "cbl b_lower")(0)
        
        Cells(s, 2) = Cells(s, 1)

        Cells(s, 3) = text2

        Cells(s, 4) = text4
            
        
        
        
        Else

'-----------------------------------------------------------------------------------------------------------------------------

       With CreateObject("htmlfile")
       
       .write text0
       
       L = .getElementsByTagName("A").Length
       
       
       
       For i = 0 To L - 1
       
       
       On Error Resume Next
       
       Cells(s, 3 * i + 2).Value = Split(.getElementsByTagName("A")(i).innerText, Chr(13))(0)
       Cells(s, 3 * i + 3).Value = Split(.getElementsByTagName("A")(i).innerText, Chr(13))(1)
       Cells(s, 3 * i + 4).Value = Split(.getElementsByTagName("A")(i).innerText, Chr(13))(2)
       
       Next
       
       
       End With
       
        
        End If

    End With
    
Next

Sub-Sub

Développer