循环浏览URL列表

Question

这段代码在循环浏览google、yahoo等URL时效果很好，但我真的是在尝试循环浏览网页，如下所示。

\\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