利用者:Junknote/削除された記事の履歴転記VBA
表示
- 特徴
- エクセル単体で削除された記事の履歴を取得し転記します。
- 使い方
- 標準モジュールに貼り付けて実行します。InputBoxへ記事名を入力すると、実行したブックのSheet(1)へ履歴を転記します。
- 注意
- ENCODEURL関数を利用しているためExcel2013以降でなければ動きません。
- 環境によっては「Microsoft XML, v6.0」などの参照設定の追加が必要かもしれません。
- ご利用は自己責任で。バグなどが見つかればお知らせください。
ソース
[編集]
Option Explicit
Public Sub Get_Del_Hist()
Const strURLbefore As String = "https://ja-two.iwiki.icu/w/api.php?action=query&format=json&prop=deletedrevisions&titles="
Const strURLafter As String = "&utf8=1&formatversion=2&drvprop=ids%7Ctimestamp%7Cflags%7Cuser%7Csize%7Ctags&drvslots=main&drvlimit=max"
Dim strTitle As String
Dim strURL As String
Dim strHtml As String
Dim xmlHttp
Dim Buf() As String
Dim strSpText() As String
Dim i As Long
Dim lngStart As Long
Dim lngCnt As Long
strTitle = InputBox("記事名を入力してください。", "deletedrevisions")
If Len(strTitle) = 0 Then Exit Sub
strURL = Application.WorksheetFunction.EncodeURL(strTitle)
strURL = strURLbefore & strURL & strURLafter
Set xmlHttp = CreateObject("Msxml2.XMLHTTP")
xmlHttp.Open "GET", strURL, False
xmlHttp.setRequestHeader "If-Modified-Since", "Thu, 01 Jun 1970 00:00:00 GMT"
xmlHttp.send
strHtml = xmlHttp.responseText
Set xmlHttp = Nothing
Buf = Split(strHtml, "{")
lngStart = 1
Do Until InStr(Buf(lngStart), "user") <> 0
lngStart = lngStart + 1
Loop
With ThisWorkbook.Sheets(1)
.Cells(1, 1) = strURL
.Cells(2, 1) = "title"
.Cells(2, 2) = strTitle
.Cells(3, 1) = "revid"
.Cells(3, 2) = "parentid"
.Cells(3, 3) = "minor"
.Cells(3, 4) = "user"
.Cells(3, 5) = "timestamp"
.Cells(3, 6) = "size"
.Cells(3, 7) = "tags"
For i = lngStart To UBound(Buf()) - 1
strSpText = Split(Replace(Replace(Buf(i), Chr(34), ""), "}", ""), ",")
lngCnt = 0
.Cells(i - lngStart + 4, 1) = Search(strSpText, "revid")
.Cells(i - lngStart + 4, 2) = Search(strSpText, "parentid")
.Cells(i - lngStart + 4, 3) = Search(strSpText, "minor")
.Cells(i - lngStart + 4, 4) = Search(strSpText, "user")
.Cells(i - lngStart + 4, 5) = Search(strSpText, "timestamp")
.Cells(i - lngStart + 4, 6) = Search(strSpText, "size")
Do Until InStr(strSpText(lngCnt), "tags:[") <> 0
strSpText(lngCnt) = ""
lngCnt = lngCnt + 1
Loop
.Cells(i - lngStart + 4, 7) = Mid$(Join(strSpText, ","), InStr(Join(strSpText, ","), "["), InStr(Join(strSpText, ","), "]") - InStr(Join(strSpText, ","), "[") + 1)
Next i
End With
End Sub
Private Function Search(strText() As String, strName As String)
On Error GoTo ErrAct
Search = Replace(Filter(strText, strName)(0), strName & ":", "")
Exit Function
ErrAct:
Search = ""
End Function