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 "