Sub MyXlMougBbs()
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Rem MOUGサイト掲示板ページ取り込み処理（HttpRequest使用）
  Rem 作譜：Hitrock Camellia Shinopy
  Rem 言語：Excel VBA
  Rem 機能...
  Rem   MOUGサイトの掲示板ページを取り込みし、
  Rem   Excelシートに書き込みする。
  Rem 注記...
  Rem   1. MyXlMougBbsを起動して使用｡
  Rem   2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。
  Rem 履歴...
  Rem   第1版：2007/06/21：作成。
  Rem   第2版：2008/04/11：保存先に「Zzz」フォルダを既定値として指定。
  Rem   第3版：2008/05/01：取り込み先のリニューアルに対処。
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  Dim myTitle As String
  Dim myFile As String
  Dim mySite As String
  Dim myArray As Variant
  Dim myLink As Variant
  '
  Dim i As Long
  Dim c As Long
  Dim myMax As Long
  '
  Dim myHTTP As Variant ' IXMLHTTPRequest
  Dim myStream As Variant ' Stream
  Dim mySource As String
  Dim myURL As String
  '
  Dim mySheetFirst As Long
  Dim myStatus As String
  Dim myStatusBar As String
  '
  Const AdBinary = 1
  Const AdTypeText = 2
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  myTitle = "MyXlMougBbs"
  myFile = "C:\Documents and Settings\User\My Documents"
  myFile = myFile & "\" & "Zzz" & "\" & myTitle & ".html"
  '
  myStatusBar = "MOUGサイト掲示板ページ取り込み処理 開始！"
  Application.StatusBar = myTitle & ": " & myStatusBar
  '
  mySite = "Moug"
  Call MyXlMougBbsSite(mySite)
  '
  myArray = Split(mySite, ",")
  myMax = UBound(myArray)
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Application.CommandBars("Task Pane").Visible = False
  Application.ScreenUpdating = False
  Range("A1").Select
  mySheetFirst = ActiveSheet.Index
  '
  c = Worksheets.Count - ActiveSheet.Index + 1
  If c < myMax Then
    c = myMax - c
    For i = 1 To c
      Worksheets.Add After:=Sheets(Worksheets.Count), Count:=1
    Next ' i
    Sheets(mySheetFirst).Activate
  End If
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  Set myHTTP = CreateObject("MSXML2.XMLHTTP") ' ("Microsoft.XMLHTTP")
  Set myStream = CreateObject("ADODB.Stream")
  '
  For i = 1 To myMax
    Sheets(mySheetFirst + i - 1).Activate
    ActiveWindow.Zoom = 80
    '
    myStatusBar = i * 100 \ myMax & "%  " & i & "/" & myMax & "頁"
    Application.StatusBar = myTitle & ": " & myStatusBar
    '
    myURL = myArray(i)
    '
    On Error Resume Next
    Call myHTTP.Open("GET", myURL, False)
    Call myHTTP.Send
    If myHTTP.readyState <> 4 Then ' 4:READYSTATE_COMPLETE
      myStatus = "接続できません。" & " readyState <> 4" & vbLf & myHTTP.statusText & vbLf
      myStatus = myStatus & "readyState: " & myHTTP.readyState & vbLf
      myStatus = myStatus & "URL: " & myURL
      Range("A1").Value = myStatus
    End If
    If myHTTP.Status <> 200 Then
      myStatus = "接続できません。" & " Status <> 200" & vbLf & myHTTP.statusText & vbLf
      myStatus = myStatus & "readyState: " & myHTTP.readyState & vbLf
      myStatus = myStatus & "URL: " & myURL
     Range("A1").Value = myStatus
    End If
    On Error GoTo 0
    '
    myStream.Type = AdBinary
    myStream.Open
    myStream.write (myHTTP.responseBody)
    myStream.Position = 0
    myStream.Type = AdTypeText
    myStream.Charset = "x-sjis" ' "EUC-JP" ' "iso-2022-jp"
    mySource = myStream.ReadText()
    Call myStream.SaveToFile(myFile, 2)
    myStream.Close
    '
    With ActiveSheet.QueryTables.Add(Connection:="FINDER;" & myFile, Destination:=Range("A1"))
      .Name = "BBS"
      .FieldNames = True
      .RowNumbers = False
      .FillAdjacentFormulas = False
      .PreserveFormatting = True
      .RefreshOnFileOpen = False
      .BackgroundQuery = False
      .RefreshStyle = xlInsertDeleteCells
      .SavePassword = False
      .SaveData = True
      .AdjustColumnWidth = True
      .RefreshPeriod = 0
      .WebSelectionType = xlSpecifiedTables
      .WebFormatting = xlWebFormattingAll
      .WebTables = "1,2"
      .WebPreFormattedTextToColumns = True
      .WebConsecutiveDelimitersAsOne = True
      .WebSingleBlockTextImport = False
      .WebDisableDateRecognition = False
      .WebDisableRedirections = False
      .Refresh BackgroundQuery:=False
    End With
    '
    Columns("A:A").ColumnWidth = 10#
    Columns("B:B").ColumnWidth = 16#
    Columns("B:B").Font.Size = 11
    '
    ActiveWindow.SmallScroll Down:=3
    ActiveSheet.Name = ActiveSheet.Range("A1").Text
    For Each myLink In ActiveSheet.Hyperlinks
      myLink.Address = Replace(myLink.Address, "C:\Documents and Settings\User\My Documents\Zzz", "http://www.moug.net/faq/")
      myLink.Address = Replace(myLink.Address, "\", "/")
      DoEvents
    Next ' myLink
    Range("B4").Select
    '
    DoEvents
  Next ' i
  Rem *----*----*    *----*----*    *----*----*    *----*----*
  '
  On Error Resume Next
  Application.ScreenUpdating = True
  Sheets(mySheetFirst).Activate
  Kill myFile
  '
  Set myHTTP = Nothing
  Set myStream = Nothing
  On Error GoTo 0
  '
  myStatusBar = "処理が終了しました。"
  Application.StatusBar = myTitle & ": " & myStatusBar & Now()
  Application.Speech.Speak myStatusBar, False
  Beep
End Sub ' MyXlMougBbs *----*----*    *----*----*    *----*----*    *----*----*

Sub MyXlMougBbsSite(mySite As String)
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=16"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=6"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=2"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=4"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=7"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=8"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=10"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=9"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=12"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=5"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=1"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=3"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=13"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=11"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=14"
  mySite = mySite & "," & "http://www.moug.net/faq/viewforum.php?f=15"
End Sub ' MyXlMougBbsSite *----*----*    *----*----*    *----*----*    *----*----*