Question

此代码在通过google，yahoo等网址循环时效果很好但我真的试图循环浏览网页，如下所示。

\\FMC9050101\Proj\6513_OAK3\Jobads\slide1.htm
\\FMC9050101\Proj\6513_OAK3\Jobads\slide2.htm
\\FMC9050101\Proj\6513_OAK3\Jobads\slide3.htm

第一个网页打开完美，但我得到并且自动化错误，“调用的对象已经与其客户端断开连接”在这一行，因为下一页被循环...想法是替换现有页面打开一个新标签。

While .Busy Or .ReadyState <> 4: DoEvents: Wend

****代码***

Dim wsSheet As Worksheet, Rows As Long, links As Variant, IE As Object, link As Variant
Set wb = ThisWorkbook
Set wsSheet = wb.Sheets("Sheet1")

Set IE = New InternetExplorer

Rows = wsSheet.Cells(wsSheet.Rows.Count, "A").End(xlUp).Row
links = wsSheet.Range("A1:A" & Rows)

With IE
    .Visible = True
    For Each link In links
        .navigate (link)
        While .Busy Or .ReadyState <> 4: DoEvents: Wend
        MsgBox .Document.body.innerText
    Next link
End With

Answer 1

好的，改变了我正在阅读服务器中的URL列表的策略，而不是excel表，这是我在解决其他问题之后的问题。使用管理员帐户，此版本可以正常运行。

Sub Run_SlideShow()
'
Dim x As Integer
Dim wsSheet As Worksheet, Rows As Long, links As Variant, IE As Object, link 
As Variant
Dim FilePath As String, Filter As String, F As Variant, I As Integer
'
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Application.EnableEvents = True
'
Set wb = ThisWorkbook
Set wsSheet = wb.Sheets("Sheet2")
Filter = "*.htm"
Set IE = CreateObject("Internetexplorer.Application")
IE.Visible = False
FilePath = "\\FMC9050101\PROJ\6513_OAK3\Jobads"

For x = 1 To 9999 ' run for 30 hours, use scheduled task to kill excel and 
restart every 24 hours
'
ArrFile = GetFileList(FilePath + "\" + Filter)
Select Case IsArray(ArrFile)
Case True
For I = LBound(ArrFile) To UBound(ArrFile)
    F = ArrFile(I)
    link = (FilePath & "\" & F)
    IE.Navigate link
    IE.Visible = True
    'Application.StatusBar = "Loading " & link
    Do While IE.Busy
        Application.Wait DateAdd("s", 2, Now) ' set slide time here
    Loop
Next
Case False 'no files found
        MsgBox "No matching files"
End Select
Next x
'
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
Application.EnableEvents = True
'
Set IE = Nothing
Application.StatusBar = ""
'
End Sub

循环访问URL列表

1 个答案: