HTMLの表を取得するには？ (ID：109652)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

> たろうさん、NHK総合のみしか出力されませんよ！

それは、そこが田舎の旅館だからでは？

というのは冗談で、IEのVersionやFontSizeなどに
おもいっきり依存してしまうでしょう。今回はList
を1つ増やし、そこにチャンネルが列挙されるように
してみました。これで環境依存はちょっとだけ緩和
されるでしょう。

Private m_colChannel As New Collection 'チャンネルCollection

Private Sub Command4_Click()
  Const IDX_TV_PROGRAM_ROOT_TABLE% = 6
    
  Dim objTable As Object 'MSHTML.HTMLTable
  Dim objCell As Object  'MSHTML.HTMLTableCell
  
  Dim blnChannelScanFlag As Boolean 'チャンネルをスキャン中Flag
  Dim strSingleLine As String '複数行になるのを1行にしたWorkString
  Dim blnNumeric As Boolean   '時間セルの場合にTrue
  Dim blnEmpty As Boolean     '空白セルの場合にTrue
    
  List1.Clear
  RichTextBox1.Text = vbNullString
    
  Set objTable = WebBrowser1.Document.getElementsByTagName( _
                 "TABLE")(IDX_TV_PROGRAM_ROOT_TABLE)
  
  blnChannelScanFlag = True
  For Each objCell In objTable.cells
    strSingleLine = Replace$(objCell.innerText, vbNewLine, " ")
    blnNumeric = isNumeric(strSingleLine)
    blnEmpty = (Len(Trim$(strSingleLine)) = 0)
    If blnChannelScanFlag Then
      'チャンネルをスキャン中...
      If blnNumeric Then
        '時間のセルが登場したのでチャンネルのスキャンは完了!
        blnChannelScanFlag = False
      ElseIf Not blnEmpty Then
        '新たなチャンネルを発見!
        m_colChannel.Add New Collection, CStr(objCell.offsetLeft)
        List1.AddItem strSingleLine
      End If
    Else
      '番組をスキャン中...
      If Not blnNumeric And Not blnEmpty Then
        '番組内容をチャンネル毎のCollectionに追加
        m_colChannel(CStr(objCell.offsetLeft)).Add objCell.innerText
      End If
    End If
  Next
  '(!)ForEachは最初にチャンネルセルをまとめてくれるという期待のもと...
End Sub

Private Sub List1_Click()
  Dim varItem As Variant
  Dim Temp_Bangumi As String
  
  For Each varItem In m_colChannel(List1.ListIndex + 1)
    Temp_Bangumi = Temp_Bangumi & CStr(varItem) & vbNewLine
  Next
  RichTextBox1.Text = Temp_Bangumi
End Sub

←解決時は質問者本人がここをチェックしてください。

戻る