Sub MyXlFanClubBbs() Rem *----*----* *----*----* *----*----* *----*----* Rem Excelファンクラブ掲示板(Q&Aラウンジ)ページ取り込み処理(HttpRequest使用) Rem 作譜:Hitrock Camellia Shinopy Rem 言語:Excel VBA Rem 機能... Rem Excelファンクラブの掲示板(Q&Aラウンジ)ページを取り込みし、 Rem Excelシートに書き込みする。 Rem 注記... Rem 1. MyXlFanClubBbsを起動して使用。 Rem 2. 初回実行前に「myFile」に取り込むRSSデータの保存先を指定すること。 Rem 履歴... Rem 第1版:2008/05/03:作成。 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 = "MyXlFanClubBbs" myFile = "C:\Documents and Settings\User\My Documents" myFile = myFile & "\" & "Zzz" & "\" & myTitle & ".html" ' myStatusBar = "Excelファンクラブ掲示板(Q&Aラウンジ)ページ取り込み処理 開始!" Application.StatusBar = myTitle & ": " & myStatusBar ' mySite = "Excelファンクラブ" Call MyXlFanClubBbsSite(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 = "exqalounge" .FieldNames = True .RowNumbers = False .FillAdjacentFormulas = False .PreserveFormatting = True .RefreshOnFileOpen = False .BackgroundQuery = True .RefreshStyle = xlInsertDeleteCells .SavePassword = False .SaveData = True .AdjustColumnWidth = True .RefreshPeriod = 0 .WebSelectionType = xlEntirePage .WebFormatting = xlWebFormattingAll .WebPreFormattedTextToColumns = True .WebConsecutiveDelimitersAsOne = True .WebSingleBlockTextImport = False .WebDisableDateRecognition = False .WebDisableRedirections = False .Refresh BackgroundQuery:=False End With ' Columns("A:A").ColumnWidth = 2# Columns("C:C").ColumnWidth = 16# Columns("D:D").Font.Size = 16# ' For Each myLink In ActiveSheet.Hyperlinks myLink.Address = Replace(myLink.Address, "C:\Documents and Settings\User\My Documents\Zzz", myURL) myLink.Address = Replace(myLink.Address, "\", "/") DoEvents Next ' myLink ' ActiveSheet.Name = Replace(ActiveSheet.Range("A1").Text, "Q&Aラウンジ ", "") ActiveSheet.Hyperlinks.Add Anchor:=Range("F124"), Address:=Range("A128").Hyperlinks(1).Address, TextToDisplay:=Range("A128").Text ' ActiveWindow.SmallScroll Down:=11 Range("F12").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 ' MyXlFanClubBbs *----*----* *----*----* *----*----* *----*----* Sub MyXlFanClubBbsSite(mySite As String) mySite = mySite & "," & "http://efcit.co.jp/cgi-bin1/exqalounge.cgi" mySite = mySite & "," & "http://www.efcit.co.jp/cgi-bin2/exqalounge.cgi" mySite = mySite & "," & "http://www.efcit.co.jp/cgi-bin3/exqalounge.cgi" mySite = mySite & "," & "http://park7.wakwak.com/~efc21/cgi-bin/exqalounge.cgi" mySite = mySite & "," & "http://efcit.co.jp/cgi-bin5/exqalounge.cgi" mySite = mySite & "," & "http://efcit.co.jp/office2000/exqalounge.cgi" End Sub ' MyXlFanClubBbsSite *----*----* *----*----* *----*----* *----*----*