Sub ボタン1_Click() ' 各種変数の定義 Dim xRow, mDir Dim AUrl, WUrl, FBURL, FPos, rCode Dim GDate As Date, MDate As Date, LDate As Date Dim XMLDoc As Object Dim Itemtitle, ItemPub, ItemCont, i, Ofl ' 前回以降に更新した記事を1ファイルにまとめて出力する(OTextに追加していき最後にファイル出力) Dim OText As Object Set OText = CreateObject("ADODB.Stream") OText.Type = adTypeText OText.Charset = "UTF-8" OText.LineSeparator = 10 OText.Open OText.WriteText "", adWriteLine OText.WriteText "", adWriteLine OText.WriteText "", adWriteLine OText.WriteText "", adWriteLine OText.WriteText "", adWriteLine ' RSS=XML取り込み処理 Set XMLDoc = CreateObject("Microsoft.XMLDOM") XMLDoc.async = False AUrl = "https://**********/rss-bridge-master/?action=display&bridge=Facebook&context=User&u=_fbac_&media_type=all&limit=5&format=Atom" mDir = ActiveWorkbook.Path Dim httpReq As XMLHTTP60 Set httpReq = New XMLHTTP60 xRow = 2 Range("C1") = 0 ' 前回実行した日時を取得 MDate = Range("E1").Value ' A2 から下に向かって順に処理 空白行があったら処理は終了 Do While Range("A" & xRow).Value <> "" If Range("C" & xRow).Value = "" Then Else FBURL = Range("C" & xRow).Value 'https://www.facebook.com/ryokyuugura/ 'https://www.facebook.com/pages/田中酒造株式会社/261168370737141 'https://www.facebook.com/青一髪-醸造元-株式会社-久保酒造場-255289987824271/ ' 一番右側が / なら削除 If Right(FBURL, 1) = "/" Then FBURL = Left(FBURL, Len(FBURL) - 1) End If ' 一番右側にある / を探す FPos = InStrRev(FBURL, "/") FBURL = Mid(FBURL, FPos + 1) ' 一番右側にある - を探す FPos = InStrRev(FBURL, "-") If FPos > 0 Then FBURL = Mid(FBURL, FPos + 1) End If WUrl = Replace(AUrl, "_fbac_", FBURL) ' URLからRSSを取得 rCode = XMLDoc.Load(WUrl) '取得確認 If rCode = False Then ' 取得できなければD列に × をセット Range("D" & xRow) = "×" Else ' 取得できたら タイトル、公開日、コンテンツを取得 Set Itemtitle = XMLDoc.SelectNodes("//entry/title") Set ItemPub = XMLDoc.SelectNodes("//entry/published") Set ItemCont = XMLDoc.SelectNodes("//entry/content") DoEvents Range("C1") = xRow - 1 Ofl = False Range("D" & xRow) = "" '記事分(最大5件)のみ処理 For i = 0 To Itemtitle.Length - 1 GDate = Mid(ItemPub(i).Text, 1, 10) & " " & Mid(ItemPub(i).Text, 12, 8) GDate = DateAdd("h", 9, GDate) ' GMTを考慮 9時間を+する ' Bridge returned error 500! (18673) のようなエラーで取得できない時は D列に − をセット If Left(Itemtitle(i).Text, 6) = "Bridge" Then Range("D" & xRow) = "−" Range("E" & xRow) = GDate Range("F" & xRow) = Itemtitle(i).Text Exit For Else ' 前回以降に投稿された記事 If MDate < GDate Then ' 最初に出現した、新しい記事なら ★ を D列にセットし、蔵の名前等を OTextにセットする ' 固定された投稿の日付が古いケースでの対応 If Ofl = False Then Range("D" & xRow) = "★" ' 日付(E列)とタイトル(F列)をセット Range("E" & xRow) = GDate Range("F" & xRow) = Itemtitle(i).Text OText.WriteText "
", adWriteLine OText.WriteText "

" & Range("A" & xRow) & ":" & Range("B" & xRow) & "

", adWriteLine OText.WriteText Range("C" & xRow) & "
", adWriteLine Ofl = True LDate = GDate Else ' 新しい記事なら日付(E列)とタイトル(F列)をセット If LDate < GDate Then Range("E" & xRow) = GDate Range("F" & xRow) = Itemtitle(i).Text LDate = GDate End If End If OText.WriteText GDate & "
", adWriteLine OText.WriteText ItemCont(i).Text & "
", adWriteLine Else End If End If Next i End If End If xRow = xRow + 1 Loop ' 処理日時を E1 にセット Range("E1").Value = Date & " " & Time OText.WriteText "", adWriteLine ' HTMLファイル出力 Const adTypeBinary = 1 Dim Path Dim Src Dim BOM Dim Buf Path = mDir & "\fbrss.html" ' Excelがあるディレクトリに「fbrss.html」というファイルで出力 OText.SaveToFile (Path), adSaveCreateOverWrite OText.Close Set OText = Nothing Set Src = CreateObject("ADODB.Stream") Src.Open Src.Type = adTypeText Src.Charset = "utf-8" Src.WriteText "" Src.Position = 0 Src.Type = adTypeBinary BOM = CStr(Src.Read(3)) ' UTF-8 BOM 削除処理 Src.LoadFromFile Path Buf = CStr(Src.Read(3)) If Buf = BOM Then Buf = Src.Read(-1) Src.Position = 0 Src.Write Buf Src.SetEOS Src.SaveToFile Path, adSaveCreateOverWrite End If Src.Close Set Src = Nothing MsgBox "終了しました" End Sub