Benutzer:Reinhard Kraasch/ListeDerAmLängstenGeschütztenArtikel.vb
Zur Navigation springen
Zur Suche springen
Public Function ListeDerAmLängstenGesperrtenArtikel(Optional ByVal Test As Boolean = False, Optional ByVal Project = "de.wikipedia.org")
Dim xmlNodes As IXMLDOMNodeList, xmlNode As IXMLDOMNode, xmlNodes1 As IXMLDOMNodeList, xmlNode1 As IXMLDOMNode, xmlNode2 As IXMLDOMNode, _
Title As String, NS As Long, RS As DAO.Recordset, RS1 As DAO.Recordset, DB As DAO.Database, Tmp, PageID As Long, Continue As String, _
Param As String, Timestamp As String, dDate, IsMove As Long, Protection, Length, Redirect, Touched, User, Comment, aType, Action, MTimeStamp, _
EditLevel, EditExpiry, MoveLevel, MoveExpiry, Level, Expiry, T, SQL
If LogMeIn(Test, Project, "RKBot", "???") Then
Set DB = CurrentDb
DB.Execute "DELETE * FROM tblLemma"
Set RS = DB.OpenRecordset("tblLemma", dbOpenDynaset)
For IsMove = True To False
Do
GetXML HttpReq, xmlDocRecv, "action=query&list=allpages&apprtype=" & IIf(IsMove, "move", "edit") & "&aplimit=max&apfrom=" & URLEncode(Continue), Test, Project
Continue = ""
Set xmlNodes = xmlDocRecv.getElementsByTagName("query-continue")
If xmlNodes.Length > 0 Then
Continue = xmlNodes(0).firstChild.Attributes(0).Text
Else
Continue = ""
End If
Set xmlNodes = xmlDocRecv.getElementsByTagName("p")
If xmlNodes.Length > 0 Then
For Each xmlNode In xmlNodes
Title = xmlNode.Attributes.getNamedItem("title").Text
PageID = xmlNode.Attributes.getNamedItem("pageid").Text
NS = xmlNode.Attributes.getNamedItem("ns").Text
dDate = Null
EditLevel = Null
EditExpiry = Null
MoveLevel = Null
MoveExpiry = Null
MTimeStamp = Null
GetXML HttpReq, xmlDocRecv, "action=query&prop=info&inprop=protection&titles=" & URLEncode(Title), Test, Project
Set xmlNodes1 = xmlDocRecv.getElementsByTagName("page")
If xmlNodes1.Length > 0 Then
For Each xmlNode1 In xmlNodes1
'Protection = xmlNode1.Attributes.getNamedItem("protection").Text
Length = 0
Redirect = "x"
Touched = Null
On Error Resume Next
Length = xmlNode1.Attributes.getNamedItem("length").Text
Redirect = xmlNode1.Attributes.getNamedItem("redirect").Text
Touched = xmlNode1.Attributes.getNamedItem("touched").Text
Touched = CDate(Replace(Replace(Touched, "T", " "), "Z", ""))
On Error GoTo 0
Next
End If
Set xmlNodes1 = xmlDocRecv.getElementsByTagName("pr")
If xmlNodes1.Length > 0 Then
For Each xmlNode1 In xmlNodes1
aType = xmlNode1.Attributes.getNamedItem("type").Text
Level = xmlNode1.Attributes.getNamedItem("level").Text
Expiry = xmlNode1.Attributes.getNamedItem("expiry").Text
If aType = "move" Then
If IsNull(MoveLevel) Or (MoveLevel = "autoconfirmed" And Level = "sysop") Then
MoveLevel = Level
MoveExpiry = Expiry
End If
ElseIf aType = "edit" Then
If IsNull(EditLevel) Or (EditLevel = "autoconfirmed" And Level = "sysop") Then
EditLevel = Level
EditExpiry = Expiry
End If
End If
Next
End If
GetXML HttpReq, xmlDocRecv, "action=query&list=logevents&lelimit=max&letype=protect&letitle=" & URLEncode(Title), Test, Project
Set xmlNodes1 = xmlDocRecv.getElementsByTagName("item")
If xmlNodes1.Length > 0 Then
For Each xmlNode1 In xmlNodes1
For Each xmlNode2 In xmlNode1.childNodes
If xmlNode2.baseName = "param" Then
Param = xmlNode2.Text
DoEvents
Exit For
End If
Next
Timestamp = xmlNode1.Attributes.getNamedItem("timestamp").Text
User = xmlNode1.Attributes.getNamedItem("user").Text
Comment = xmlNode1.Attributes.getNamedItem("comment").Text
aType = xmlNode1.Attributes.getNamedItem("type").Text
Action = xmlNode1.Attributes.getNamedItem("action").Text
If IsMove And (InStr(Param, "[move=") > 0 Or InStr(Param, "[Verschieben=") > 0) Or _
Not IsMove And (InStr(Param, "[edit=") > 0 Or InStr(Param, "[Bearbeiten=") > 0) Then
dDate = CDate(Replace(Replace(Timestamp, "T", " "), "Z", ""))
End If
If Action = "protect" Then MTimeStamp = Timestamp
If Not IsNull(dDate) Then Exit For
Next
End If
DoEvents
If IsNull(dDate) And Not IsNull(MTimeStamp) Then
dDate = CDate(Replace(Replace(MTimeStamp, "T", " "), "Z", ""))
End If
If Not IsNull(dDate) Then
If InStr(Title, "'") = 0 Then
RS.FindFirst "Title = '" & Replace(Title, "'", "''") & "'"
Else
RS.FindFirst "Title = """ & Replace(Title, """", """""") & """"
End If
If RS.NoMatch Then
RS.AddNew
RS!Title = Title
RS!PageID = PageID
RS!Touched = Touched
RS!Length = Length
RS!Redirect = Redirect = ""
RS!MoveLevel = MoveLevel
RS!MoveExpiry = MoveExpiry
If Not IsNull(MoveExpiry) Then
If MoveExpiry = "infinity" Then
RS!MoveProtectedUntil = CDate("9999-12-31")
Else
RS!MoveProtectedUntil = CDate(Replace(Replace(MoveExpiry, "T", " "), "Z", ""))
End If
End If
RS!EditLevel = EditLevel
RS!EditExpiry = EditExpiry
If Not IsNull(EditExpiry) Then
If EditExpiry = "infinity" Then
RS!EditProtectedUntil = CDate("9999-12-31")
Else
RS!EditProtectedUntil = CDate(Replace(Replace(EditExpiry, "T", " "), "Z", ""))
End If
End If
RS!NS = NS
Else
RS.Edit
End If
DoEvents
If IsMove Then
RS!MoveProtectedSince = dDate
RS!MoveProtectUser = User
RS!MoveProtectComment = Comment
Else
RS!EditProtectedSince = dDate
RS!EditProtectUser = User
RS!EditProtectComment = Comment
End If
RS.Update
End If
Next
End If
Loop Until Continue = ""
Next IsMove
RS.Close
Set RS = DB.OpenRecordset("tblLemma", dbOpenDynaset)
Do Until RS.EOF
Title = RS!Title
T = GetText(Title)
If InStr(T, "{{BKL}}") > 0 Or InStr(T, "{{Begriffsklärung}}") > 0 Then
RS.Edit
RS!BKL = True
RS.Update
End If
If InStr(T, "{{Falschschreibung") > 0 Then
RS.Edit
RS!Falschschreibung = True
RS.Update
End If
RS.MoveNext
Loop
RS.Close
SQL = "SELECT Lemma,GeschütztSeit,GeschütztBis,Benutzer,Kommentar FROM qryEditProtected WHERE editlevel ='sysop'"
TableToFile SQL, CurrentProject.Path & "\EditProtectedSysop.txt"
SQL = "SELECT Lemma,GeschütztSeit,GeschütztBis,Benutzer,Kommentar FROM qryEditProtected WHERE editlevel ='autoconfirmed'"
TableToFile SQL, CurrentProject.Path & "\EditProtectedAutoconfirmed.txt"
End If
End Function
Public Function GetText(Optional Title = "", Optional Test As Boolean = False, Optional Project = "de.wikipedia.org") As String
Dim xmlNodes As IXMLDOMNodeList, xmlNode As IXMLDOMNode
GetText = ""
If LogMeIn(Test, Project, "RKBot", "???") Then
GetXML HttpReq, xmlDocRecv, "action=query&prop=revisions&rvprop=content&titles=" & URLEncode(Title), Test, Project
Set xmlNodes = xmlDocRecv.getElementsByTagName("rev")
If xmlNodes.Length > 0 Then GetText = xmlNodes(0).Text
End If
End Function