GDIplusCODE


'Microsoft Internet Control
'Microsoft HTML Object Library
'に参照設定
Declare Sub Sleep Lib "kernel32" (ByVal dwMilliseconds As Long)



Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                    (ByVal lpClassName As String, _
                    ByVal lpWindowName As String) As Long
                    
'TD内をスキャンして取得したテキストを収納する
'TDタグ内に、二つの文字列があるといった複雑な表に対応するため、ModuleレベルのCollectionを使用
Dim textCollection As Collection

Dim ie As WebBrowser

Sub getTableFromOpenPage()
  Dim ie As WebBrowser
  'AとBが相違しているのがなんか変だがこうしないとエラーになる。
  '従って、インテリセンスも効かないで大変だがやむを得ず。
  Dim doc As IHTMLDocument '-A
  
  Dim tbElements As IHTMLElementCollection
  Dim trNodes As IHTMLDOMChildrenCollection
  Dim tdNodes As IHTMLDOMChildrenCollection
  Dim tbElement As IHTMLElement
  Dim trNode As IHTMLDOMNode
  Dim tdNode As IHTMLDOMNode
  Dim tempNode As IHTMLDOMNode
  
  Dim tblCnt As Long
  Dim rowCnt As Long
  Dim columnCnt As Long
  Dim collectCnt As Long
  Dim wbk As Workbook
  Dim sh As Worksheet
  Dim buf As String
  
  Dim i As Long, j As Long, k As Long
  Dim tableCaption As String
  Dim destCell As Range
  
  Set ie = getTopIeTab
  If ie Is Nothing Then Exit Sub
  Set doc = New HTMLDocument '-B
  
  doc.write ie.document.body.outerHTML
  Set tbElements = doc.getElementsByTagName("table")
  If tbElements.Length = 0 Then Exit Sub
  Set wbk = ThisWorkbook
  tblCnt = 1 'Tableのカウンター
  Do While tbElements.Length > wbk.Worksheets.Count
    wbk.Worksheets.Add
  Loop
  For Each sh In wbk.Worksheets
    sh.Cells.Clear
  Next sh
  For Each tbElement In tbElements
    'Table毎にワークシートを変える
    Set sh = wbk.Sheets(tblCnt)
    '<table>の下に、ソース上は存在しない<TBODY>が存在している
    '<tr>タグはその下にあるらしい
    
    '気象庁のページ　<TBODY>と並列に、その前に<CAPTION>というタグがある
    'このため、ChildNodesのところで、「実装されていません」という訳の分からないエラーが出た
    'nodeNameがTBODYのところから引っ張ってくる様にした。
    For j = 0 To tbElement.ChildNodes.Length
      Select Case tbElement.ChildNodes(j).nodeName
        Case "CAPTION"
          tableCaption = tbElement.ChildNodes(j).FirstChild.NodeValue
        Case "TBODY"
          Set trNodes = tbElement.ChildNodes(j).ChildNodes
          Exit For
      End Select
    Next j
    sh.Cells(1).Value = tableCaption
  
    rowCnt = 2 '行のカウンター
    For Each trNode In trNodes
      '名前はtdNodeであるが、tdとthを含む
      columnCnt = 1 '列のカウンター
      
      For Each tdNode In trNode.ChildNodes
        Set textCollection = New Collection
        buf = ""
        getNodeText tdNode
        If textCollection.Count > 0 Then
          For collectCnt = 1 To textCollection.Count
            If collectCnt = 1 Then
              buf = textCollection.Item(collectCnt)
            Else
              buf = buf & "," & textCollection.Item(collectCnt)
            End If
          Next collectCnt
        End If
        '行、列方向の結合に対応
        Set destCell = sh.Cells(rowCnt, columnCnt)
        Do While destCell.MergeCells = True
          Set destCell = destCell.Offset(0, 1)
          columnCnt = columnCnt + 1
        Loop
        '
        destCell.Value = buf
        ' <TH rowSan= xx>の、rowSpanといった属性は、Node.Attributesからは取得できない
        '（lengthが100個以上にのぼる別ものらしい。メンバもnodeと類似したものである）
        'Nodeの種類に応じて動的にメンバを有しており（インテリセンスで表示されない）決め打ちで取得可能
        'node.colSpan, node.rowSpanという様に。確認するには条件を満足したらStopするコードを組んでおいて
        'Local Windowで確認すれば可能。
        
        If tdNode.colSpan > 1 Or tdNode.rowSpan > 1 Then
          destCell.Resize(tdNode.rowSpan, tdNode.colSpan).Merge
        End If
        Set textCollection = Nothing
        columnCnt = columnCnt + 1
      Next tdNode
      rowCnt = rowCnt + 1
    Next trNode
    tblCnt = tblCnt + 1
  Next tbElement
  Set doc = Nothing
  Exit Sub

End Sub

'ノード内の全Textを取得してCollection（モジュールレベル変数）に納める関数
'再帰使用している
Sub getNodeText(myNode As IHTMLDOMNode)
  Dim myChildNode As IHTMLDOMNode
  Dim buf As String
  
  '半角スペース1個という#textが存在するページあり
  If myNode.nodeName = "#text" And Trim(myNode.NodeValue) <> "" Then
    textCollection.Add myNode.NodeValue
    Exit Sub
  End If
  '下位のnodeまで調べる
  If myNode.HasChildNodes Then
    For Each myChildNode In myNode.ChildNodes
      getNodeText myChildNode
    Next myChildNode
  End If
End Sub

'IEの最前面Tabを取得
Function getTopIeTab(Optional matchWord As String) As WebBrowser
  Dim hWnd As Long
  Dim ie As WebBrowser
  Dim targetIe As WebBrowser
  Const IEClassName As String = "IEFrame"     'IEのClass名
  
  hWnd = FindWindow(IEClassName, vbNullString)
  If hWnd = 0 Then Exit Function
  For Each ie In CreateObject("Shell.Application").Windows()
    If hWnd = ie.hWnd Then
      ie.StatusBar = True
      ie.statusText = CStr(hWnd)
      If ie.statusText = CStr(hWnd) Then
        If matchWord = "" Then
            Set getTopIeTab = ie
            Exit Function
        Else
          If InStr(ie.LocationURL, matchWord) > 0 Then
            Set getTopIeTab = ie
            Exit Function
          End If
        End If
      End If
    End If
  Next ie
  Set getTopIeTab = Nothing
End Function

☆おまけ　Webページの構造を、IEでXMLを開いた時の様に階層構造でWorksheetに出力する－Attribute表示改良中
'結構処理時間がかかるので留意のこと。
’IE8と、IE9以降の分岐が必要かもしれない。
'http://blogs.msdn.com/b/ie_jp/archive/2011/10/03/10219055.aspx

'Microsoft Internet Control
'Microsoft HTML Object Library
'に参照設定

Private Declare Function FindWindow Lib "user32" Alias "FindWindowA" _
                    (ByVal lpClassName As String, _
                    ByVal lpWindowName As String) As Long
                    
'ワークシートへの出力行を示す変数（再帰使用するのでモジュールレベルで宣言）
Dim myRow As Long

Sub analyzeWebPage()
  Dim ie As InternetExplorer
  Dim doc As IHTMLDocument '-A
  Dim chNode As IHTMLDOMNode
  Dim i As Long, j As Long, k As Long
  Dim wbk As Workbook
  Dim sh As Worksheet
    
  Set ie = getTopIeTab
  If ie Is Nothing Then Exit Sub
  Set doc = New HTMLDocument '-B
  Set doc = ie.document
  Set wbk = ThisWorkbook
  Set sh = wbk.Sheets(1)
  sh.Cells.ClearContents
  sh.Activate
  
  myRow = 1

  'Docのメンバはインテリセンスされないので、Stopしてローカルウィンドウで調査
  For Each chNode In doc.ChildNodes
    scanNode chNode, 1
  Next chNode
  Set doc = Nothing
  sh.Cells.WrapText = False
End Sub


'再帰的にスキャンして下位NodeのTagと値をセルに出力する
Sub scanNode(myNode As IHTMLDOMNode, myLevel As Long)
  Dim myChildNode As IHTMLDOMNode
  Dim newLevel As Long
  Dim i As Long
  Dim myAttribute As IHTMLDOMAttribute
  Dim buf As String
  
  newLevel = myLevel + 1
  Select Case myNode.NodeType
    Case 3
      Cells(myRow, myLevel).Value = myNode.NodeValue
    Case 8
      Cells(myRow, myLevel).Value = myNode.NodeValue
    Case Else
      If Not myNode.Attributes Is Nothing Then
        For i = 0 To myNode.Attributes.Length - 1
          Set myAttribute = myNode.Attributes(i)
          If myAttribute.specified And myAttribute.Value <> "" Then
            buf = buf & " " & myAttribute.nodeName & " = '" & myAttribute.NodeValue & "'"
          End If
        Next i
          Cells(myRow, myLevel).Value = "<" & myNode.nodeName & buf & ">"
      Else
        Cells(myRow, myLevel).Value = "<" & myNode.nodeName & ">"
      End If
  End Select
      myRow = myRow + 1
  If myNode.HasChildNodes Then
    For Each myChildNode In myNode.ChildNodes
      scanNode myChildNode, newLevel
    Next myChildNode
  End If
End Sub

'nodeType
'1 要素ノード
'2 属性ノード
'3 テキストノード
'4 CDATA ノード
'5 実体参照ノード
'6 実体ノード
'7 処理命令ノード
'8 注釈宣言ノード
'9 文書ノード
'10  文書型宣言ノード
'11  文書切片ノード
'12  表記法ノード


'IEの最前面Tabを取得
Function getTopIeTab(Optional matchWord As Variant) As InternetExplorer
  Dim hWnd As Long
  Dim ie As InternetExplorer
  Dim targetIe As InternetExplorer
  Const IEClassName As String = "IEFrame"     'IEのClass名
  
  hWnd = FindWindow(IEClassName, vbNullString)
  For Each ie In CreateObject("Shell.Application").Windows()
    If hWnd = ie.hWnd Then
      ie.StatusBar = True
      ie.statustext = CStr(hWnd)
      If ie.statustext = CStr(hWnd) Then
        If IsMissing(matchWord) Then
            Set getTopIeTab = ie
      ie.statustext = ""
            Exit Function
        Else
          If InStr(ie.LocationURL, matchWord) > 0 Then
            Set getTopIeTab = ie
            Exit Function
          End If
        End If
      End If
    End If
  Next ie
  Set getTopIeTab = Nothing
End Function

'今後使用予定
Function getIEversion() As String
    Dim fso As Object
    Dim ieVersion As String
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    ieVersion = fso.GetFileVersion("C:\Program Files\Internet Explorer\IEXPLORE.EXE ")
    '11.0.9600.16521
    getIEversion = Split(ieVersion, ".")(0)
    Set fso = Nothing
End Function

'☆ おまけ2 TextNodeのテキスト取得法のIEバージョンによる動作の違いを試すためのコード
'VirtualBox(Windows2000)で試したが結果は同じだった。IE6をインストールしてある筈だが、IEのファイルバージョンは5であった？
'Microsoft Internet Control
'Microsoft HTML Object Library
'に参照設定


Sub test()
  Dim doc As IHTMLDocument '-A
  Dim chNode As IHTMLDOMNode
  Dim myNodes As IHTMLElementCollection
  Dim buf As String
    
  Set doc = New HTMLDocument '-B
  buf = "<html><head></head><body><p>test</p></body></html>"
  doc.write buf
  Set myNodes = doc.getElementsByTagName("p")
  
  Debug.Print myNodes.Length  '1(IE11)
  With myNodes(0)
    Debug.Print .nodeName   'P(IE11)
    Debug.Print .NodeValue  'Null(IE11)
    Debug.Print .NodeType   '1(IE11)
    Debug.Print .innerText  'test(IE11)
    Debug.Print .FirstChild.NodeValue 'test(IE11)
    Debug.Print .innerHTML    'test(IE11)
    Debug.Print .outerHTML    '<P>test</P>(IE11)
    Debug.Print .HasChildNodes 'true(IE11)
  End With
  With myNodes(0).FirstChild
    Debug.Print .nodeName   '#text(IE11)
    Debug.Print .NodeValue  'test(IE11)
    Debug.Print .NodeType   '3(IE11)
    'Debug.Print .innerText '非サポート(IE11)
    'Debug.Print .innerHTML  '非サポート(IE11)
    'Debug.Print .outerHTML  '非サポート(IE11)
    Debug.Print .HasChildNodes 'False(IE11)
    
  End With
  'Stop 'local windowでメンバを探る
  Set doc = Nothing
End Sub

'☆ おまけ3 WebPageを動的に作成。javascriptのコードも与えてやる。
'docment.script.setTimeoutの制限がきつくなった事もあり、発展型を下記にのせました。
発展的移転先：Excel/VBAからJavaScriptのコードを実行してみる
MSHTML DOM を使ってWebページのTabelをExcel Worksheetに取り込む
