怎么把百度地图的搜索结果全部导出到Excel文件

VBA万岁

回复22楼鄂多蒙：
Sub 百度地图搜索结果导出文件()
Dim url, html, js
ActiveSheet.UsedRange.Offset(1).ClearContents
br = [{"店名","地址","电话"}]
Range("a1:c1") = br
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To 5
    With CreateObject("msxml2.xmlhttp")
        url = "http://map.baidu.com/?newmap=1"
        url = url & "&reqflag=pcmap"
        url = url & "&biz=1"
        url = url & "&from=webmap"
        url = url & "&qt=s"
        url = url & "&from=webmap"
        url = url & "&c=" & Split([E1], "|")(1)
        url = url & "&pl_data_type=cater"
        url = url & "&pl_sub_type=" & [F1]
        url = url & "&pl_price_section=0%2C%2B"
        url = url & "&pl_sort_type=data_type"
        url = url & "&pl_sort_rule=0"
        url = url & "&pl_discount2_section=0%2C%2B"
        url = url & "&pl_groupon_section=0%2C%2B"
        url = url & "&pl_cater_book_pc_section=0%2C%2B"
        url = url & "&pl_ticket_book_flag_section=0%2C%2B"
        url = url & "&pl_movie_book_section=0%2C%2B"
        url = url & "&pl_business_type=cater"
        url = url & "&pl_business_id="
        url = url & "&pl_activity_gwj_section=0%2C%2B"
        url = url & "&wd=" & [F1]
        url = url & "&pn=1"
        url = url & "&db=0"
        url = url & "&wd2="
        url = url & "&sug=0"
        url = url & "&da_src=pcmappg.poi.page"
        url = url & "&on_gel=1"
        url = url & "&src=7"
        url = url & "&gr=3"
        url = url & "&l=12"
        url = url & "&addr=0"
        url = url & "&nn=" & (p - 1) * 10
        url = url & "&tn=B_NORMAL_MAP"
        url = url & "&ie=utf-8"
        url = url & "&t=1412423900383"
        .Open "get", url, False
        .send
        js.addcode ("suwenkai = " & .responsetext)
        If js.Eval("suwenkai.content") = False Then
            Exit For
        End If
        slen = js.Eval("suwenkai.content.length") - 1
        For i = 0 To slen
            n = n + 1
            Cells(n + 1, 1) = js.Eval("suwenkai.content[" & i & "].name")
            Cells(n + 1, 2) = js.Eval("suwenkai.content[" & i & "].addr")
            Cells(n + 1, 3) = js.Eval("suwenkai.content[" & i & "].tel")
        Next
    End With
Next
End Sub

Sub 更新地名ID号()
Dim html, i%, j%, t, t2 As String
With CreateObject("msxml2.xmlhttp")
    .Open "get", "http://webmap0.map.bdstatic.com/newmap/static/common/pkg/init-pkg_75a504f.js", False
    .send
    t = Split(Split(.responsetext, "){var i=""")(1), """")(0)
    For i = 0 To UBound(Split(t, ","))
        t2 = t2 & Split(t, ",")(i) & ","
    Next i
End With
Range("E1").Validation.Delete: Range("e1").Validation.Add Type:=xlValidateList, Operator:=xlBetween, Formula1:=Mid(t2, 1, Len(t2) - 1): Range("e1").Select
End Sub

VBA万岁

回36楼学良大师：

工作表代码：
Public arr

Private Sub Worksheet_Activate()
Dim html, i%, j%, t, t2 As String
With CreateObject("msxml2.xmlhttp")
    .Open "get", "http://webmap0.map.bdstatic.com/newmap/static/common/pkg/init-pkg_75a504f.js", False
    .send
    t = Split(Split(.responsetext, "){var i=""")(1), """")(0)
    For i = 0 To UBound(Split(t, ","))
        t2 = t2 & Split(t, ",")(i) & ","
    Next i
End With
arr = Split(t2, ",")
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
If Target.Count > 1 Then GoTo 100: Exit Sub
If Target.Address <> "$F$1" Then GoTo 100: Exit Sub
[d4] = ""
With Me.TextBox1
    .Visible = True
    .Top = Target.Offset(1, 0).Top
    .Left = Target.Left
    .Width = Target.Width
    .Height = Target.Height + 10
    .Activate
End With
With Me.ListBox1
    .Visible = True
    .Top = Target.Offset(1, 0).Top
    .Left = Target.Left + Target.Width
    .Height = Target.Height * 10
    .List = arr
End With

Exit Sub
100:
    Me.ListBox1.Clear
    Me.TextBox1 = ""
    Me.ListBox1.Visible = False
    Me.TextBox1.Visible = False
End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)
    ActiveCell.Value = ListBox1.Value
    Me.ListBox1.Clear
    Me.TextBox1 = ""
    Me.ListBox1.Visible = False
    Me.TextBox1.Visible = False
    [e4].Select
End Sub

Private Sub TextBox1_KeyUp(ByVal KeyCode As MSForms.ReturnInteger, ByVal Shift As Integer)
Dim i As Integer
Dim Language As Boolean
Dim myStr As String
Me.ListBox1.Clear
With Me.TextBox1
    For i = 1 To Len(.Value)
        If Asc(Mid$(.Value, i, 1)) > 255 Or Asc(Mid$(.Value, i, 1)) < 0 Then
            Language = True
            myStr = myStr & Mid$(.Value, i, 1)
        Else
            myStr = myStr & UCase(Mid$(.Value, i, 1))
        End If
    Next
End With
    For i = 1 To UBound(arr)
        If InStr(arr(i), myStr) > 0 Then
            Me.ListBox1.AddItem arr(i)
        End If
    Next
End Sub

模块代码：
Sub 百度地图搜索结果导出文件()
Dim url, html, js
ActiveSheet.UsedRange.Offset(1).ClearContents
br = [{"店名","地址","电话"}]
Range("a1:c1") = br
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To 5
    With CreateObject("msxml2.xmlhttp")
        url = "http://map.baidu.com/?newmap=1"
        url = url & "&reqflag=pcmap"
        url = url & "&biz=1"
        url = url & "&from=webmap"
        url = url & "&qt=s"
        url = url & "&from=webmap"
        url = url & "&c=" & Split([F1], "|")(1)
        url = url & "&pl_data_type=cater"
        url = url & "&pl_sub_type=" & [D1]
        url = url & "&pl_price_section=0%2C%2B"
        url = url & "&pl_sort_type=data_type"
        url = url & "&pl_sort_rule=0"
        url = url & "&pl_discount2_section=0%2C%2B"
        url = url & "&pl_groupon_section=0%2C%2B"
        url = url & "&pl_cater_book_pc_section=0%2C%2B"
        url = url & "&pl_ticket_book_flag_section=0%2C%2B"
        url = url & "&pl_movie_book_section=0%2C%2B"
        url = url & "&pl_business_type=cater"
        url = url & "&pl_business_id="
        url = url & "&pl_activity_gwj_section=0%2C%2B"
        url = url & "&wd=" & [D1]
        url = url & "&pn=1"
        url = url & "&db=0"
        url = url & "&wd2="
        url = url & "&sug=0"
        url = url & "&da_src=pcmappg.poi.page"
        url = url & "&on_gel=1"
        url = url & "&src=7"
        url = url & "&gr=3"
        url = url & "&l=12"
        url = url & "&addr=0"
        url = url & "&nn=" & (p - 1) * 10
        url = url & "&tn=B_NORMAL_MAP"
        url = url & "&ie=utf-8"
        url = url & "&t=1412423900383"
        .Open "get", url, False
        .send
        js.addcode ("suwenkai = " & .responsetext)
        If js.Eval("suwenkai.content") = False Then
            Exit For
        End If
        slen = js.Eval("suwenkai.content.length") - 1
        For i = 0 To slen
            n = n + 1
            Cells(n + 1, 1) = js.Eval("suwenkai.content[" & i & "].name")
            Cells(n + 1, 2) = js.Eval("suwenkai.content[" & i & "].addr")
            Cells(n + 1, 3) = js.Eval("suwenkai.content[" & i & "].tel")
        Next
    End With
Next
End Sub

VBA万岁

回37楼Suwenkai大师：
其中71楼的“更新地名ID号”过程、72楼的“Private Sub Worksheet_Activate”过程均能快速提取各地的ID号，但只限于县级以上地名的ID号，县级以下的地名ID号无法提取。

VBA万岁

窗体版代码：
Dim varData, L

Private Sub CommandButton1_Click()
Dim url, html, js, arr
ReDim arr(0 To Val(TextBox3.Text) * 10, 0 To 2)
ListBox2.Clear
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To Val(TextBox3.Text)
    With CreateObject("msxml2.xmlhttp")
        url = "http://map.baidu.com/?newmap=1"
        url = url & "&reqflag=pcmap"
        url = url & "&biz=1"
        url = url & "&from=webmap"
        url = url & "&qt=s"
        url = url & "&from=webmap"
        url = url & "&c=" & Split(TextBox1.Text, "|")(1)
        url = url & "&pl_data_type=cater"
        url = url & "&pl_sub_type=" & TextBox2.Text
        url = url & "&pl_price_section=0%2C%2B"
        url = url & "&pl_sort_type=data_type"
        url = url & "&pl_sort_rule=0"
        url = url & "&pl_discount2_section=0%2C%2B"
        url = url & "&pl_groupon_section=0%2C%2B"
        url = url & "&pl_cater_book_pc_section=0%2C%2B"
        url = url & "&pl_ticket_book_flag_section=0%2C%2B"
        url = url & "&pl_movie_book_section=0%2C%2B"
        url = url & "&pl_business_type=cater"
        url = url & "&pl_business_id="
        url = url & "&pl_activity_gwj_section=0%2C%2B"
        url = url & "&wd=" & TextBox2.Text
        url = url & "&pn=1"
        url = url & "&db=0"
        url = url & "&wd2="
        url = url & "&sug=0"
        url = url & "&da_src=pcmappg.poi.page"
        url = url & "&on_gel=1"
        url = url & "&src=7"
        url = url & "&gr=3"
        url = url & "&l=12"
        url = url & "&addr=0"
        url = url & "&nn=" & (p - 1) * 10
        url = url & "&tn=B_NORMAL_MAP"
        url = url & "&ie=utf-8"
        url = url & "&t=1412423900383"
        .Open "get", url, False
        .send
        js.addcode ("suwenkai = " & .responsetext)
        If js.Eval("suwenkai.content") = False Then
            Exit For
        End If
        slen = js.Eval("suwenkai.content.length") - 1
        For i = 0 To slen
            n = n + 1
            For j = 0 To 2
                arr(n - 1, j) = js.Eval("suwenkai.content[" & i & "]." & Array("name", "addr", "tel")(j))
            Next j
        Next
    End With
Next
ListBox2.List = arr
End Sub

Private Sub ListBox1_Click()
    TextBox1.Text = ListBox1.Value
End Sub

Private Sub UserForm_Initialize()
Dim html, i%, j%, t, t2 As String
With CreateObject("msxml2.xmlhttp")
    .Open "get", "http://webmap0.map.bdstatic.com/newmap/static/common/pkg/init-pkg_75a504f.js", False
    .send
    t = Split(Split(.responsetext, "){var i=""")(1), """")(0)
    For i = 0 To UBound(Split(t, ","))
        t2 = t2 & Split(t, ",")(i) & ","
    Next i
End With
ListBox1.List = Split(t2, ","): ListBox1.ListIndex = 28
varData = Split(t2, ",")
TextBox2.Text = "餐饮": TextBox3.Text = 5
End Sub

Private Sub TextBox1_Change()
Dim i As Long
Dim strFind As String
   
strFind = "*" & UCase(Me.TextBox1.Text) & "*"
   
With ListBox1
    If Len(Me.TextBox1.Text) < L Then
        .List = varData
    End If
    L = Len(Me.TextBox1.Text)
    For i = .ListCount - 1 To 0 Step -1
        If (Not UCase(.List(i, 0)) Like strFind) Then
            .RemoveItem i
        End If
    Next i
End With
End Sub

VBA万岁

其中：TextBox1中输入百度地图搜索地名（含ID值），TextBox2输入搜索关键字，TextBox输入搜索的最大页码，TextBox1与ListBox1之间建立模糊查询输入，ListBox2显示搜索结果。

aman1516

VBA万岁 发表于 2015-4-9 17:06
其中：TextBox1中输入百度地图搜索地名（含ID值），TextBox2输入搜索关键字，TextBox输入搜索的最大页码，T ...

能否上个“成品”附件，更多的应用测试下，也便于大家学习理解

loveEXCELforeve

大神，膜拜

VBA万岁

回76楼：
由于公司网络限制，现无法上附件，过些时间我换一个网络试试。

VBA万岁

按钮代码作如下改变可在ListBox2中获取相应链接：
Private Sub CommandButton1_Click()
On Error Resume Next
Dim url, html, js, arr
ReDim arr(0 To Val(TextBox3.Text) * 10, 0 To 3)
ListBox2.Clear
url = ""
Set html = CreateObject("htmlfile")
Set js = CreateObject("scriptcontrol")
js.Language = "jscript"
For p = 1 To Val(TextBox3.Text)
    With CreateObject("msxml2.xmlhttp")
        url = "http://map.baidu.com/?newmap=1"
        url = url & "&reqflag=pcmap"
        url = url & "&biz=1"
        url = url & "&pcevaname=pc2"
        url = url & "&from=webmap"
        url = url & "&qt=s"
        url = url & "&wd=" & TextBox2.Text
        url = url & "&c=" & Split(TextBox1.Text, "|")(1)
        url = url & "&sefrom=1"
        url = url & "&tn=B_NORMAL_MAP"
        url = url & "&nn=" & (p - 1) * 10
        url = url & "&ie=utf-8"
        url = url & "&l=12"
        url = url & "&b=11528083.25,4260714.36;11587283.25,4307434.36"
        url = url & "&t=1428631758687"
        .Open "get", url, False
        .send
        js.addcode ("百度结果 = " & .responsetext)
        If js.Eval("百度结果.content") = False Then
            Exit For
        End If
        slen = js.Eval("百度结果.content.length") - 1
        For i = 0 To slen
            n = n + 1
            For j = 0 To 3
                arr(n - 1, j) = js.Eval("百度结果.content[" & i & "]." & Array("name", "addr", "tel", "ext.detail_info.link[0].url")(j))
            Next j
        Next
    End With
Next
ListBox2.List = arr
End Sub

VBA万岁

同时增加如下代码，以在单击ListBox2时可打开相应链接：
Private Sub ListBox2_Click()
    With CreateObject("internetexplorer.application")
        .Visible = True
        .Navigate ListBox2.List(ListBox2.ListIndex, 3)
        Do Until .ReadyState = 4
            DoEvents
        Loop
    End With
End Sub