使用 vba 复制已打开的 IE 页面上的所有内容

Question

我知道如何打开一个新的并复制所有内容。

而且我还知道如何引用已经打开的 IE 页面。

我正在努力从已经打开的 Internet Explorer 页面复制

请帮忙。

Function GetIE() As Object
'return an object for the open Internet Explorer window, or create new one
  For Each GetIE In CreateObject("Shell.Application").Windows() 'Loop to find
    If (Not GetIE Is Nothing) And GetIE.Name = "Internet Explorer" Then Exit For 'Found!
  Next GetIE
  If GetIE Is Nothing Then Set GetIE = CreateObject("InternetExplorer.Application") 'Create
  GetIE.Visible = True 'Make IE window visible

  ' (this is where the code fail) down

        IE.ExecWB 17, 0 '// SelectAll
        IE.ExecWB 12, 2 '// Copy selection
        ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
        Range("A1").Select
        IE.Quit

End Function

基本上我需要这段代码：使用已经打开的 IE 窗口而不是 URL

Sub Test() 

    Dim IE As Object 

    Sheets("Sheet3").Select 
    Range("A1:A1000") = "" ' erase previous data
    Range("A1").Select 

    Set IE = CreateObject("InternetExplorer.Application") 
        With IE 
            .Visible = True 
            .Navigate "http://www.aarp.org/" ' should work for any URL
            Do Until .ReadyState = 4: DoEvents: Loop 
        End With 

        IE.ExecWB 17, 0 '// SelectAll
        IE.ExecWB 12, 2 '// Copy selection
        ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False 
        Range("A1").Select 
        IE.Quit 

End Sub

Answer 1

如果您只想打开一个 IE 窗口，则可以使用 GetObject()。

如果您想获得一个特定打开的窗口（通过 URL），那么您可以执行以下操作：

Sub tester()
    Dim IE As Object

    Set IE = GetIE("http://www.aarp.org/")
    If Not IE Is Nothing Then
        IE.ExecWB 17, 0 '// SelectAll
        IE.ExecWB 12, 2 '// Copy selection
        ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False 
        Range("A1").Select 
        IE.Quit 
    End If
End sub

使用这个：

'get a reference to an existing IE window, given a partial URL
Function GetIE(sLocation As String) As Object

    Dim objShell As Object, objShellWindows As Object, o As Object
    Dim sURL As String
    Dim retVal As Object

    Set retVal = Nothing
    Set objShell = CreateObject("Shell.Application")
    Set objShellWindows = objShell.Windows

    For Each o In objShellWindows
        sURL = ""
        On Error Resume Next  'because may not have a "document" property
        'Check the URL and if it's the one you want then
        ' assign the window object to the return value and exit the loop
        sURL = o.document.Location
        On Error GoTo 0
        If sURL Like sLocation & "*" Then
            Set retVal = o
            Exit For
        End If
    Next o

    Set GetIE = retVal

End Function

Answer 2

我建议您尝试使用下面的代码示例进行测试，可以帮助您将网页内容从已打开的 IE 实例复制到 Excel 工作表中。

VBA 代码：

Sub demo()

Sheets("Sheet1").Select
Range("A1:A1000") = ""
Range("A1").Select


    Set objShell = CreateObject("Shell.Application")
    IE_count = objShell.Windows.Count
        For x = 0 To (IE_count - 1)
        On Error Resume Next
    
            my_title = objShell.Windows(x).document.Title

            If my_title Like "AARP? Official Site - Join & Explore the Benefits" & "*" Then
                Set IE = objShell.Windows(x)
       
                If Not IE Is Nothing Then
                    IE.ExecWB 17, 0
                    IE.ExecWB 12, 2
                    ActiveSheet.PasteSpecial Format:="Text", link:=False, DisplayAsIcon:=False
                    Range("A1").Select
                    'IE.Quit
                End If
            Exit For
            Else
            End If
        Next

End Sub

输出：

此外，您可以根据自己的要求修改代码示例。