vba采集网页运行时错误 '-2147024891 (80070005)':拒绝访问

游戏人生生

自己写了个程序，主要是采集网页上面数据进行分析，程序运行大概20~30行的时候出错，运行时错误 '-2147024891 (80070005)':拒绝访问

游戏人生生

Dim check_bool, cutdate


Sub check()
Worksheets(1).[d2:d65535] = ""
Worksheets(1).[e2:e65535] = ""
Worksheets(2).[a2:a65535] = ""
Worksheets(3).[a2:a65535] = ""
Worksheets(4).[a2:a65535] = ""

For i = 2 To Range("C65536").End(xlUp).Row

  If i Mod 25 = 1 Then
    waitTime = TimeSerial(Hour(Now()), Minute(Now()), Second(Now()) + 10)
    Application.Wait waitTime
  End If

  If Sheets(1).Cells(i, 2).Value = "" Then
  GoTo x:
  End If
  If Sheets(1).Cells(i, 3).Value = "" Then
  GoTo x:
  End If
stra = Sheets(1).Cells(i, 3).Value
stra = Replace(stra, "http://", "")
stra = Replace(stra, " ", "")
stra = "http://" + stra
strb = Sheets(1).Cells(i, 2).Value
strb = Replace(strb, " ", "")

Call test(stra, strb)


If check_bool = 1 Then
    Sheets(1).Cells(i, 4) = "存在"
    Sheets(1).Cells(i, 5) = cutdate
    u = Worksheets(3).[a65536].End(xlUp).Row + 1
    Sheets(3).Cells(u, 1) = Sheets(1).Cells(i, 1).Value
Else
    If check_bool = -1 Then
        Sheets(1).Cells(i, 4) = "锁定"
        Sheets(1).Cells(i, 5) = cutdate
        u = Worksheets(4).[a65536].End(xlUp).Row + 1
        Sheets(4).Cells(u, 1) = Sheets(1).Cells(i, 1).Value
    Else
        Sheets(1).Cells(i, 4) = "不存在"
        Sheets(1).Cells(i, 5) = cutdate
        u = Worksheets(2).[a65536].End(xlUp).Row + 1
        Sheets(2).Cells(u, 1) = Sheets(1).Cells(i, 1).Value
    End If
End If
x:
Next
End Sub



Function test(WEBurl, mingzi)
    Dim strRespText$, tt$, i&, DW$
    tt = ""
    Dim url
    url = WEBurl
    Set obj = CreateObject("Msxml2.XMLHTTP.5.0")
   
    With obj
       obj.Open "GET", url, False
        obj.Send
        tt = obj.responsetext
        tt = BytesToBstr(obj.ResponseBody, "gb2312")
        If InStr(1, tt, mingzi) > 0 Then
           check_bool = 1
        Else
           If InStr(1, tt, "还需进一步完善") > 0 Then
           check_bool = 0
           Else
           check_bool = -1
           End If
        End If
        Call CutData(tt)
        obj.Close
        
    End With
End Function



Function BytesToBstr(strBody, CodeBase)
    Dim objStream
    On Error Resume Next
    Set objStream = CreateObject("Adodb.Stream")
    With objStream
        .Type = 1
        .Mode = 3
        .Open
        .Write strBody
        .Position = 0
        .Type = 2
        .Charset = CodeBase
        BytesToBstr = .ReadText
    End With
    objStream.Close
    Set objStream = Nothing
    If Err.Number <> 0 Then BytesToBstr = ""
    On Error GoTo 0
End Function



Function CutData(tt)
     bw = Split(tt, "<span id=""lastModifyTime"">")
     bw = Split(bw(1), "</span>")
     cutdate = bw(0)
End Function

游戏人生生

帮忙分析一下

fu201314

  下面这段代码以前运行正常，现在运行到 .Send 就出现   【   运行时错误 '-2147024891 (80070005)':拒绝访问  】
  With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "http://917500.cn/data/cqssc_400.txt", False
        .Send
        s = Split(.responseText, Chr(10))
    End With

my0745

楼主解决了吗

v2hero

同问啊！原来都是好好的，不知道是不是对方网络服务器设置的相关的保护机制，但是获取内容的网址代码放在浏览器里面可以正常打开。不知道是什么原因。有没有大神可以解释下

x-xx-xx

嗯我也遇到了据说wps不行excel可以我去装个excel试试

perfect131

试试用vbs

ml8562

网址头http后加s，试一试。

perfect131

用 CreateObject("MSXML2.ServerXMLHTTP")