Sub MyXlBss()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 山陰放送サイト[ニュース]ページ取り込み処理（外部データの取り込み・HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   山陰放送サイトの[ニュース]ページを読み込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   MyXlBssを起動して使用｡
  Rem 履歴...
  Rem   第1版：2006/09/30：作成。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem 参照設定する場合...
  Rem   Microsoft Internet Controls
  Rem   Microsoft HTML Object Library
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTags As Variant ' DispHTMLElementCollection
  Dim myTag As Variant ' HTMLDivElement
  '
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myIE As Variant ' InternetExplorer
  Dim myDoc As Variant ' MSHTML.HTMLDocument
  Dim myLink As Variant ' MSHTML.HTMLAnchorElement
  '
  Dim myURL As String
  Dim h As Variant ' Hyperlink
  Dim r As Long
  Dim myMax As Long
  Dim myStatusBar As String
  Dim myText As String
  Dim myinnerText As String
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = False
  On Error Resume Next
  ActiveSheet.Next.Select
  If (Err.Number <> 0) Then
    Sheets.Add After:=Worksheets(Worksheets.Count)
    ActiveSheet.Previous.Select
  End If
  On Error GoTo 0
  '
  myStatusBar = "□山陰放送 ニュース 読み込み開始"
  Application.StatusBar = "MyXlBss: " & myStatusBar
  '
  Range("A1").Select
  myURL = "http://bss.jp/scripts/vnews.cgi"
  '
  With ActiveSheet.QueryTables.Add(Connection:="URL;" & myURL, Destination:=Range("A1"))
    .Name = "vnews"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingAll
    .WebTables = "1"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
  End With
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  ActiveSheet.Next.Cells(1, 1).Value = "山陰放送（BSS）ニュース"
  ActiveSheet.Next.Cells(1, 2).Value = Cells(3, 1).Text
  '
  r = 3
  For Each h In ActiveSheet.Hyperlinks
    ActiveSheet.Next.Cells(r, 1).Value = h.TextToDisplay
    ActiveSheet.Next.Cells(r, 2).Value = h.Name
    '
    r = r + 1
    DoEvents
  Next ' ActiveSheet.Hyperlinks
  myMax = r - 1
  '
  ActiveSheet.Next.Select
  ActiveSheet.Name = "山陰放送"
  Columns("A:A").ColumnWidth = 30#
  Columns("B:B").ColumnWidth = 80#
  ActiveWindow.Zoom = 75
  Rows("1").RowHeight = 30#
  Rows("2").RowHeight = 30#
  '
  For r = 3 To myMax
    Cells(r, "A").Select
    Cells(r, "A").Hyperlinks.Add Anchor:=Selection, Address:=Cells(r, "B").Value, _
                                                    TextToDisplay:=Cells(r, "A").Text
    DoEvents
  Next ' r
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Rem 本文の取り込み
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myIE = CreateObject("InternetExplorer.Application")
  '
  For r = 3 To myMax
    myURL = Cells(r, "B").Text
    '
    With myIE
      .Navigate "about:blank"
      .Visible = False ' True
      Do While .Busy
        DoEvents
      Loop
      myStatusBar = "●読み込み中：" & r * 100 \ myMax & "%　"
      myStatusBar = myStatusBar & r & "/" & myMax & "行　"
      Application.StatusBar = "MyXlBss: " & myStatusBar
      DoEvents
      Set myDoc = .Document
    End With
    '
    Call myHTTP.Open("GET", myURL, False)
    Call myHTTP.Send
    If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.readyState: " & myHTTP.readyState & vbCr
      myStatusBar = myStatusBar & "URL: " & myURL
      MsgBox myStatusBar, vbOKOnly, "MyXlBss"
      GoTo MyXlBssSubExit
    End If
    If myHTTP.Status <> 200 Then
      myStatusBar = "接続できません。" & vbCr & myHTTP.statusText & vbCr
      myStatusBar = myStatusBar & "myHTTP.Status: " & myHTTP.Status & vbCr
      myStatusBar = myStatusBar & "URL: " & myURL
      MsgBox myStatusBar, vbOKOnly, "MyXlBss"
      GoTo MyXlBssSubExit
    End If
    '
    myText = StrConv(myHTTP.responseBody, vbUnicode)
    myText = Replace(myText, " src=", " Zzzsrc=")
    myDoc.write myText
    '
    Set myTags = myDoc.getElementsByTagName("tr")
    myinnerText = myTags.Item(0).innerText
    myinnerText = myinnerText & vbLf & myTags.Item(1).innerText & vbLf
    Cells(r, "B").Select
    Selection.VerticalAlignment = xlTop
    Cells(r, "B").Value = myinnerText
    DoEvents
  Next ' r
  Cells(1, "B").Select
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
MyXlBssSubExit:
  ActiveSheet.Previous.Select
  Application.DisplayAlerts = False
  ActiveSheet.Delete
  Application.DisplayAlerts = True
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = "MyXlBss: " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  '
  myIE.Visible = True
  myIE.Quit
  Application.ScreenUpdating = True
  Beep
  '
  Set myHTTP = Nothing
  Set myIE = Nothing
  Set myDoc = Nothing
End Sub ' MyXlBss *----*----*    *----*----*    *----*----*    *----*----*