提前网页信息，用到当前浏览器

'Option Explicit

Public Const lngStartRow As Long = 2 '起始输入行

Dim n As Long

Dim objDic As Object

Dim strRef As String, objIE As Object

Dim IsOpen As Boolean

Dim objframe As Object

Sub 网页元素分析()

    URL = "https://search.douban.com/movie/subject_search?search_text=tt0770442&cat=1002" '测试

    Set objIE = FindWin(URL) '先查找该网页是否已打开

    If objIE Is Nothing Then

        Set objIE = CreateObject("internetexplorer.application")

        With objIE

            .Visible = False

            .Navigate URL '打开网页

            Do While .ReadyState <> 4 Or .Busy

                DoEvents

            Loop

        End With

    Else

        IsOpen = True

    End If

    'Application.ScreenUpdating = False

    Set objDic = CreateObject("scripting.dictionary")

    DoEvents

    Call FindFrame(objIE.Document.Frames, ".Document.") '寻找每个frame的内容

    DoEvents

    Cells.WrapText = False '单元格取消自动换行

    Application.ScreenUpdating = True

    Set objDic = Nothing

    Set objIE = Nothing

    MsgBox "完毕！"

End Sub

Sub FindFrame(ByVal objframe As Object, ByVal CellName As String)

    '递归查找frame

    Dim i As Long

    DoEvents

    Call OutPutAllCell(objframe, CellName) '输出元素内容

    For i = 0 To objframe.Length - 1

        objDic.RemoveAll

        Call FindFrame(objframe(i), CellName & "frames(" & i & ").Document.")

    Next

End Sub

Sub OutPutAllCell(ByVal objframe As Object, ByVal CellName As String)

    '输出元素属性

    Dim subitem As Object

    Dim strCode As String

    Dim strID As String

    Dim j As Integer

    Dim 元素代码(), 长度(), 标识(), 名字(), 标识名(), type值(), 值(), href(), 内部数据()

    On Error Resume Next

    n = 0

    For Each subitem In objframe.Document.all

        n = n + 1

        objDic(subitem.tagName) = objDic(subitem.tagName) + 1

        strCode = "(" & subitem.tagName & ")" & "(" & objDic(subitem.tagName) - 1 & ")"

        strID = subitem.ID

        If strID = "" Then strID = subitem.Name

        ThisWorkbook.Sheets("Sheet1").Cells(n + 2, 1).Value = strCode '将数据放入第一个表格检测

        ThisWorkbook.Sheets("Sheet1").Cells(n + 2, 2).Value = subitem.all.Length

        For j = 3 To ThisWorkbook.Sheets("Sheet1").Cells(2, Columns.Count).End(xlToLeft).Column

            ThisWorkbook.Sheets("Sheet1").Cells(n + 2, j).Value = CallByName(subitem, ThisWorkbook.Sheets("Sheet1").Cells(2, j).Value, VbGet)

        Next

    Next

    Set subitem = Nothing

End Sub

Function FindWin(ByVal strRef As String) As Object

    '找寻已打开的网页

    Dim objWin As Object

    For Each objWin In CreateObject("Shell.Application").Windows

        Do While objWin.ReadyState <> 4 Or objWin.Busy

            DoEvents

        Loop

        If LCase(TypeName(objWin.Document)) = "htmldocument" Then

            If objWin.LocationURL = strRef Then

                Set FindWin = objWin

                Exit For

            End If

        End If

    Next

    Set objWin = Nothing

End Function