User:Smallbot/source/Beaverton Oregon Historical Gallery

From Wikimedia Commons, the free media repository
Jump to: navigation, search

The following is the source code used for Commons:Bots/Requests/Smallbot 4.

You need XP+, IE6+ (for mshtml), and .net 2+ (for fiddler).

The download is done in vbscript w/ xhr for the http requests, mshtml for the html parsing, ADOB.stream for the reading/writing, Msxml2.DOMDocument for the xml. Images are encoded as base64 (which inflates their size ~33%) so they can be stored as plain text in the xml file.

XHR-> Microsoft.XMLHTTP (MSXML2.XMLHTTP.3.0)

VBScript, while old, is easy to use for COM scripting without requiring casting. MSHTML is used as it will parse tag soup (and often, that mess is meant for IE and will choke other parsers). Also, due to its age, VBScript works on virtually all windows machines. VB6 is no longer supported.

PowerShell 3 has Invoke-WebRequest which is promising. Alternatively, Qt has QtWebKit, but requires more code than VBScript.

Source[edit]

The source code is released under the MIT license


MIT logo.svg
This file is licensed under the Expat License, sometimes known as the MIT License:

Copyright © 2012 Smallman12q

Permission is hereby granted, free of charge, to any person obtaining a copy of this software and associated documentation files (the "Software"), to deal in the Software without restriction, including without limitation the rights to use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of the Software, and to permit persons to whom the Software is furnished to do so, subject to the following conditions:

The above copyright notice and this permission notice shall be included in all copies or substantial portions of the Software.

The Software is provided "as is", without warranty of any kind, express or implied, including but not limited to the warranties of merchantability, fitness for a particular purpose and noninfringement. In no event shall the authors or copyright holders be liable for any claim, damages or other liability, whether in an action of contract, tort or otherwise, arising from, out of or in connection with the Software or the use or other dealings in the Software.


Deutsch | English | فارسی | Français | 日本語 | Македонски | Nederlands | Português | Português do Brasil | Русский | Svenska | 中文 | 中文(简体)‎ | 中文(繁體)‎ | +/−

Download[edit]

Following the download, a root xml tag is added with Quick Editor 4 (Quick Editor 3.5).

Const btonxml = "C:\Beaverton.xml" 'XML file where data is stored
Const btoncsv = "C:\bton.csv" 'ID stored
Dim html: Set html = CreateObject("htmlfile") 'MSHTML.HTMLDocument
Dim http: Set http = CreateObject("Microsoft.XMLHTTP") 'MSXML2.XMLHTTP.3.0
Dim xmldoc: Set xmldoc = CreateObject("Msxml2.DOMDocument")
 
'Setup regex for catching years in title
Dim re: Set re = New regexp 	
re.Pattern = "\b1[89][0-9]{2}\b" 'http://utilitymill.com/utility/Regex_For_Range
 
'Write to file after every image
Const ForAppending = 8
Dim fs: Set fs = CreateObject("Scripting.FileSystemObject")
Dim file: Set file = fs.OpenTextFile(btonxml, ForAppending, True,0) '0=ANSI, -1=Unicode
 
Const ForReading = 1
Dim fcsv: Set fcsv = fs.OpenTextFile(btoncsv, ForReading, True,0)
Dim csvdata: csvdata = "" 'sort of csv ... data is ",#,,#,,#,"
Do While Not fcsv.AtEndOfStream
  csvdata = csvdata + fcsv.ReadAll
Loop
WScript.Echo csvdata
fcsv.Close
Set fcsv = fs.OpenTextFile(btoncsv, ForAppending, True,0)
 
'12 Categories
Dim cats: cats = Array("Aerial", "Airport", "Buildings", "Businesses", "Churches", "Events", "Lumbermill", "Other", "People", "Schools", "Streets", "Transportation")
 
Dim catcounter, catname    
'For Each cat In cats
For catcounter = 0 To 13 'Change here to number of cats
        Set html = Nothing
        Set html = CreateObject("htmlfile") 'New instance
        catname = cats(catcounter)
 
        WScript.StdOut.WriteLine "CAT: " & catname & "(" & catcounter & ")"
 
        'Dim county: Set county = xmldoc.createElement("county")
        'xmldoc.appendChild(county)
        file.WriteLine("<cat id=""" & catname & """>")
 
        '''''''''
        'Get number of images from cat 
        http.open "GET", "http://apps.beavertonoregon.gov/HistoricPhotos/category_results.aspx?cat=" & catname , False
        http.send
        html.write(http.responseText)
 
        Dim numberofimages : numberofimages= html.getElementsByTagName("span")(2).innerHTML
        Dim imagesread: imagesread = 1
 
        'Read cat data
        Dim ispancounter : ispancounter= 3
        For imagesread = 1 To numberofimages
        	WScript.StdOut.WriteLine "Reading: " & imagesread & "/" & numberofimages
        	'MsgBox "1"
        	If ispancounter > 22 Then 'Reset at end and load next page
        		'MsgBox "here1"
        		ispancounter= 3
        			'html.forms.
        			'Dim viewstate : viewstate = html.getElementsByTagName("span")(0).
        			Dim viewstate : viewstate = html.getElementsByTagName("input")(0).value'html.forms("ctl00").__VIEWSTATE.Value
 
        			Dim eventvalidation : eventvalidation = html.getElementsByTagName("input")(2).value 'html.forms("ctl00").__EVENTVALIDATION.Value
        			Dim sRequest : sRequest= "__VIEWSTATE=" & EncodeURI(viewstate) &_
        									"&__VIEWSTATEENCRYPTED=&__EVENTVALIDATION=" & EncodeURI(eventvalidation) &_
        									"&btnNext=Next%C2%BB"		
 
        			'html.clear
                	html.open "about:blank"
                	'html.updateSettings()
 
					http.open "POST", "http://apps.beavertonoregon.gov/HistoricPhotos/category_results.aspx?cat=" & catname , False
					http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
					http.setRequestHeader "Content-Length", Len(sRequest)
					http.send sRequest
 
					html.write (http.responseText)
 
        	End If
 
        	Dim imagename : imagename = html.getElementsByTagName("span")(ispancounter).innerHTML
 
        	'MsgBox "2"
 
        	Dim tempid
        	Dim picyear
        	If Left(imagename,6) = "&nbsp;" Then
        		tempid = Split(Split(imagename,"?id=")(1),Chr(34))(0)'"
        		'tempid = tempid(1),"'")
        		imagename = "Unknown"
        	Else
        		tempid = Split(imagename," - ")(0)
        		imagename = Split(imagename," - ")(1)
        	End If
        	'Ids may be duplicate, check when uploading
 
        	'Extract year from imagename
			Set picyear = re.Execute(imagename)
			If picyear.Count = 1 Then
				picyear = picyear.Item(0).Value
			Else
				picyear = ""
			End If
 
        	Dim source: source = Replace(html.getElementsByTagName("img")(ispancounter - 1).src,"_t.jpg","_p.jpg")
 
 
 
            'about:
            '1234567
            source = "http://apps.beavertonoregon.gov/HistoricPhotos/" & Mid(source,7)
 
            Dim stempid: stempid = "," + tempid + ","
            Dim b64
            If(InStr(1,csvdata,stempid) <= 0) Then
	            http.open "GET", source, False
	            http.send
 
				Set b64 = xmldoc.createElement("imagedata")
				With b64
					.dataType = "bin.base64"
				    .nodeTypedValue = http.responseBody
				End With
 
				csvdata = csvdata + stempid
				fcsv.Write(stempid)
 
			Else
				Set b64 = xmldoc.createElement("imagedata")
			End If
 
			'http.close
 
			'''''''''''''
			'Write out nodes
			Dim image: Set image = xmldoc.createElement("image")
            xmldoc.appendChild(image)
 
			caddelement "title", imagename
			caddelement "id", tempid
			caddelement "year", picyear
			caddelement "src", source
			image.appendChild(b64)
 
			file.WriteLine PrettyPrintXml (xmldoc)
            xmldoc.removeChild(image)
            WScript.StdOut.WriteLine "Written."
            WScript.Sleep 5000
 
        	'MsgBox source
 
        	'MsgBox numberofimages
			'MsgBox imagename & "|" & tempid
        	ispancounter = ispancounter + 1
        Next
        file.WriteLine("</cat>")
Next
WScript.StdOut.WriteLine "Done."
WScript.StdIn.ReadLine
 
Function EncodeURI(data)
	'http://stackoverflow.com/questions/9628080/get-value-from-a-javascript-function-in-vbscript
	'http://stackoverflow.com/questions/332872/how-to-encode-a-url-in-javascript
 
	'use with caution
	'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q266343
 
	Dim d: Set d = html.parentWindow
	d.execScript("var UrlEscape = function(){return encodeURIComponent('"& data & "');}")
    EncodeURI = d.UrlEscape()
End Function
 
Sub caddelement(elementname, elementvalue) 'image add element
        Dim element: Set element = xmldoc.createElement(elementname)
        element.text = elementvalue
        'Dim value : Set value = xmldoc.createTextNode(elementvalue)
        'element.appendChild(value)  'Set the element value
        image.appendChild(element) 'Add element to county
End Sub
 
'http://stackoverflow.com/questions/4328907/add-child-entry-to-a-specific-node-in-xml-file-in-vbscipt
Function PrettyPrintXml(xmldoc)
    Dim reader
    set reader = CreateObject("Msxml2.SAXXMLReader.6.0")
    Dim writer
    set writer = CreateObject("Msxml2.MXXMLWriter.6.0")
    writer.indent = True
    writer.omitXMLDeclaration = True
    reader.contentHandler = writer
    reader.putProperty "http://xml.org/sax/properties/lexical-handler", writer
    reader.parse(xmldoc)
    PrettyPrintXml = writer.output
End Function

Image source order[edit]

Also see User:Smallbot/source/Oregon Historical County Records Guide#Tag Name number and User:Smallbot/source/Oregon Historical County Records Guide#Link number.

var w = window.open('', '', 'width=1000,height=500,resizable,scrollbars');
w.document.open();
w.document.write("<html><head><title>Viewing image...</title></head>");
w.document.write("<body onload = 'self.focus()'>");
 
 
 var element = "IMG"
 var elements = document.getElementsByTagName(element);
 
 if(elements.length > 0)
 {
       w.document.write("<h5>" + element + "</h5>");
 
       //start table
       w.document.write("<table border=\"1\" title=\"" + element + "\">");
       w.document.write("<tr>");
       w.document.write("<th>#</th>");
       w.document.write("<th>src</th>");
       w.document.write("<tr>");
 
       //write rows
       for (var elementscounter = 0; elementscounter < elements.length; elementscounter+=1)
       {
               w.document.write("<tr>");
               w.document.write("<td name=\"" + elementscounter + "\">" + elementscounter + "</td>");
               w.document.write("<td><pre><code>" + elements[elementscounter].src +"</code></pre></td>");
               w.document.write("</tr>");
       }
 
       //close table
       w.document.write("</table>");
       w.document.write("<br/>");
}
w.document.write("</body></html>");
w.document.close();

Upload[edit]

The source xml file can be found at dropbox (~210MB).

Const user = "user"
Const pass = "password"
Const btonxml = "C:\Beaverton.xml" 'XML file where data is stored
Const upcounterstart = 0 'start at end/ next upcounter
Const  upcounterend = 400
 
''
Dim html: Set html = CreateObject("htmlfile") 'MSHTML.HTMLDocument
Dim http: Set http = CreateObject("Microsoft.XMLHTTP") 'MSXML2.XMLHTTP.3.0
Dim objXMLDoc: Set objXMLDoc = CreateObject("Msxml2.DOMDocument")'"Microsoft.XMLDOM") 
Class Bimage
   Public c, t, i, y, s, d
End Class
 
Dim Bimages(350)
 
 
'''''''''''''''
'Can also use https
Dim Console: Set Console = WScript.StdOut
 
''''Login
Dim x 'node
 
Console.WriteLine  "Logging in as :" & user 
Console.WriteLine "Logging in... 1/2"
'initial post
wikipost "format=xml&action=login&lgname=" & Escape(user) & "&lgpassword=" & Escape(pass),0
nodeset "//api/login/@result"
If x Is Nothing Then
        Console.WriteLine "Couldn't find initial login token."
        Quit
End If
If x.value <> "NeedToken" Then        
        Console.WriteLine  "Couldn't get initial login token."
        Quit
End If
 
'Repost with token
Console.WriteLine "Logging in... 2/2"
nodeset "//api/login/@token"
wikipost "format=xml&action=login&lgname=" & Escape(user) & "&lgpassword=" & Escape(pass) & "&lgtoken=" & x.value,0
nodeset "//api/login/@result"
If x Is Nothing Then
        WScript.Echo "Couldn't find login result."
        Quit
End If
If x.value <> "Success" Then
        Console.WriteLine "Login failed."
        Quit
End If
Console.WriteLine "Successfully logged in"
 
'''Edit Token
Dim edittoken
'Get edittoken from main talkpage
Console.WriteLine "Retrieving edit token..."
wikipost "format=xml&action=query&prop=info&intoken=edit&titles=Talk:Main%20Page", 0
nodeset("//api/query/pages/page/@edittoken")
If x Is Nothing Then
        Console.WriteLine "Couldn't find edittoken."
        Quit
End If
If x.value = "+\" Then
        Console.WriteLine "Invalid edittoken."
        Quit
End If
edittoken = x.value
Console.WriteLine("Edit token retrieved: " & edittoken)
 
'Multipart variables
Dim boundary: boundary = "8G9lbpohjyr5ewclo0ho" 'Should be more random
 
'''ADODB.Stream
Dim Stream : Set Stream = CreateObject("ADODB.Stream")
'Type
Const adTypeBinary = 1
Const adTypeText = 2
'State
Const adStateClosed = 0
Const adStateOpen = 1
 
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
objXMLDoc.async = False 
objXMLDoc.validateOnParse = True
objXMLDoc.load(btonxml)'b.xml")
'MsgBox "loaded"
 
Dim root: Set root = objXMLDoc.documentElement 
'MsgBox root.xml
Dim cats: Set cats = root.getElementsByTagName("cat") 
 
 
Dim cat
For Each cat In cats 
 
	Dim catname: catname = cat.Attributes.item(0).text
	Dim images: Set images = cat.childNodes'getElementsByTagName("image")
 
	Dim image
	For Each image In images
 
		Dim imagen : Set imagen = image.childNodes
 
		'Dim title: Set title = image.getElementsByTagName("title")(0)		
		Dim ititle:  ititle = imagen.nextNode.text
		Dim iid:  iid = imagen.nextNode.text
		Dim iyear:  iyear = imagen.nextNode.text
		Dim isrc: isrc = imagen.nextNode.text
		Dim idata: idata = imagen.nextNode.nodeTypedValue
 
		If TypeName(idata) = "Byte()" Then 'Not set yet
 
			Set Bimages(iid) = New Bimage
			Bimages(iid).c = catname
			Bimages(iid).t = ititle
			Bimages(iid).y = iyear
			Bimages(iid).s = isrc
			Bimages(iid).d = idata
 
			'MsgBox iid
 
		Else 'Already set
			Bimages(iid).c = Bimages(iid).c & "," & catname					
		End If
 
		'MsgBox ititle & "|" & iid & "|" & iyear & "|" & CStr(idata)
   	Next
Next
 
Dim upcounter: upcounter = 0
 
Dim i
For i = 0 to UBound(Bimages)
	If IsObject(Bimages(i)) Then
		'WScript.StdOut.WriteLine Bimages(i).t & "|" & Bimages(i).c & "|" & i
		'Exist so upload
 
		If upcounter => upcounterstart Then 'Maybe Upload
 
			If upcounter < upcounterend Then 'Upload
				WScript.StdOut.WriteLine "-------------------------------------------------"
				WScript.StdOut.WriteLine upcounter & "|" & Bimages(i).t & "|" & i
 
				Dim categories : categories = Split(Bimages(i).c,",")
				Dim categoriestext : categoriestext = ""
				Dim category
				For Each category In categories
					categoriestext = categoriestext + vbNewLine & "[[Category:" & category & " images of Beaverton, Oregon]]"
				Next
 
 
				'Generate template + category
				Dim template: template = "{{Information " & vbNewLine &_
					"|Description= {{en|1=" & Bimages(i).t & ". Historical images of {{w|Beaverton, Oregon}}.}}" & vbNewLine &_
					"|Date= " & Bimages(i).y & vbNewLine &_
					"|Source= {{en|1=[http://apps.beavertonoregon.gov/HistoricPhotos/ Beaverton Oregon Historical Photo Gallery]:" &_
					       " [http://apps.beavertonoregon.gov/HistoricPhotos/category_results.aspx?cat=" & Bimages(i).c & " " & Bimages(i).c & " Gallery]" &_
					       " [" & Bimages(i).s & " Direct]}}" & vbNewLine &_
					"|Author= {{unknown photographer}}" & vbNewLine &_
					"|Permission= {{Beaverton Oregon Historical Photo Gallery}}" & vbNewLine &_
					"|Other_fields= " & vbNewLine &_
					       "{{Information field|name=Photo No. |value= " & i & "}}" & vbNewLine &_
					"}}" & vbNewLine &_
					categoriestext
 
				'WScript.StdOut.WriteLine(template)
				'Upload file
				multipartpost Bimages(i).d, _
				    Bimages(i).t & " (Beaverton, Oregon Historical Photo Gallery) (" & i & ").jpg", _
				    template, _
				    "[[Commons:Bots/Requests/Smallbot 4]]: Uploading  images from Beaverton, Oregon Historical Photo Gallery"
				'Assume success...else check response in fiddler2
 
				upcounter = upcounter + 1
			Else 'Quit
				WScript.StdOut.WriteLine "Upload batch portion finished."
				WScript.StdIn.ReadLine
				WScript.Quit
			End If
		Else ' Skip
			upcounter = upcounter + 1
		End If 
	End If
Next
 
WScript.StdOut.WriteLine "Upload batch complete."
WScript.StdIn.ReadLine
WScript.Quit
 
''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''''
'''''''''''''''''''''''''''''''''''
Sub wikipost(payload, attempt)
        http.open "POST","https://commons.wikimedia.org/w/api.php",False
        http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        http.send (payload)
        If (httpstatus() = false) Then
                If attempt < 3 Then
                        wikipost payload, attempt + 1
                Else
                        Console.WriteLine "POST FAILED|" & payload
                        'Quit, HTTP errors
                End If
        End If
End Sub
 
'Returns false if not 200 response
Function httpstatus()
        If http.status <> 200 Then
                httpstatus = False
        End If
        httpstatus = True
End Function
 
Sub nodeset(node)
        Set x= http.responseXML.selectSingleNode(node)
End Sub
 
Sub Quit
        Console.WriteLine "Quit"
        WScript.Quit
End Sub
 
Function editpage (page,text,summary)
        wikipost "format=xml&action=edit&title=" & Encode(page) & "&text=" & Encode(text) & "&summary=" & Encode(summary) &"&bot=1"& "&token=" & Encode(edittoken), 0
        nodeset "//api/edit/@result"
 
        If x Is Nothing Then
                'error
                Console.WriteLine "Edit page error->nothing->" & page
                Quit
        End If
        If x.value <> "Success" Then
                'error
                Console.WriteLine "Edit page failure." & page
                Quit
        End If
        editpage = 1
End Function
 
Sub multipartpost(source, filename, desc, comment)
        http.open "POST","https://commons.wikimedia.org/w/api.php",False
        http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
 
        Dim uploaddata
 
        Dim params: params = Array("action","format","filename","text","comment","ignorewarnings","token")
        Dim values: values = Array("upload","xml",filename,desc,comment,"1",edittoken)
        Dim count
        For count=0 To 6
                uploaddata = uploaddata & vbNewLine & "--" & boundary & vbNewLine &_
                "Content-Disposition: form-data; name=" & chr(34) & params(count) & chr(34) & vbNewLine &_
                "Content-Type: text/plain" & vbNewLine &_
                 vbNewLine & values(count)
        Next
 
        'application/octet-stream
        'image/jpg
        http.Send ConcatByteArrays( _
                ConcatByteArrays( _
                        StringToBinary(uploaddata & vbNewLine & "--" & boundary & vbNewLine &_
                                "Content-Disposition: form-data; name=" & chr(34) & "file" & chr(34) &"; filename=" &  chr(34) & filename & chr(34) & vbNewLine &_
                                "Content-Type: application/octet-stream" & vbNewLine &_
                                "Content-Transfer-Encoding: binary" & vbNewLine &_
                                vbNewLine), _
                        source), _
                StringToBinary(vbNewLine &_
                "--" & boundary & "--" & vbNewLine))
End Sub
 
'http://stackoverflow.com/questions/184574/how-to-append-binary-values-in-vbscript
Function ConcatByteArrays(bytearray1, bytearray2)
 
        ClearStream
        'Open stream and write 1st, 2nd byte array
        Stream.Open
        Stream.Type = adTypeBinary 'Binary
        Stream.Write bytearray1
        Stream.Write bytearray2
 
        Stream.Position = 0 'Reset position to read from start
 
        ConcatByteArrays = Stream.Read
        'Stream.Close
End Function
 
Sub ClearStream
        If Stream.State <> adStateClosed Then
                Stream.Close
        End If
End Sub
 
'http://www.motobit.com/tips/detpg_binasp/
Function StringToBinary(Text)
        ClearStream
 
        'Set as text stream
        Stream.Type = adTypeText
        Stream.CharSet = "us-ascii" 'can change to others
 
        'Write text to stream
        Stream.Open
        Stream.WriteText Text
 
        'Change stream to binary
        Stream.Position = 0 'Set position to 0 first
        Stream.Type = adTypeBinary
 
        'Open the stream as binary
        StringToBinary = Stream.Read
        'Stream.Close
End Function
 
Function Encode(data)
	'http://stackoverflow.com/questions/9628080/get-value-from-a-javascript-function-in-vbscript
	'http://stackoverflow.com/questions/332872/how-to-encode-a-url-in-javascript
 
	'use with caution
	'http://support.microsoft.com/default.aspx?scid=kb;EN-US;q266343
 
	Dim d: Set d = html.parentWindow
	d.execScript("var UrlEscape = function(){return escape('"& data & "');}")
    EncodeURI = d.UrlEscape()
End Function

Create Categories[edit]

Const user = "user"
Const pass = "pass"
 
''
Dim html: Set html = CreateObject("htmlfile") 'MSHTML.HTMLDocument
Dim http: Set http = CreateObject("Microsoft.XMLHTTP") 'MSXML2.XMLHTTP.3.0
Dim objXMLDoc: Set objXMLDoc = CreateObject("Msxml2.DOMDocument")'"Microsoft.XMLDOM") 
 
'''''''''''''''
'Can also use https
Dim Console: Set Console = WScript.StdOut
 
''''Login
Dim x 'node
 
Console.WriteLine  "Logging in as :" & user 
Console.WriteLine "Logging in... 1/2"
'initial post
wikipost "format=xml&action=login&lgname=" & Escape(user) & "&lgpassword=" & Escape(pass),0
nodeset "//api/login/@result"
If x Is Nothing Then
        Console.WriteLine "Couldn't find initial login token."
        Quit
End If
If x.value <> "NeedToken" Then        
        Console.WriteLine  "Couldn't get initial login token."
        Quit
End If
 
'Repost with token
Console.WriteLine "Logging in... 2/2"
nodeset "//api/login/@token"
wikipost "format=xml&action=login&lgname=" & Escape(user) & "&lgpassword=" & Escape(pass) & "&lgtoken=" & x.value,0
nodeset "//api/login/@result"
If x Is Nothing Then
        WScript.Echo "Couldn't find login result."
        Quit
End If
If x.value <> "Success" Then
        Console.WriteLine "Login failed."
        Quit
End If
Console.WriteLine "Successfully logged in"
 
'''Edit Token
Dim edittoken
'Get edittoken from main talkpage
Console.WriteLine "Retrieving edit token..."
wikipost "format=xml&action=query&prop=info&intoken=edit&titles=Talk:Main%20Page", 0
nodeset("//api/query/pages/page/@edittoken")
If x Is Nothing Then
        Console.WriteLine "Couldn't find edittoken."
        Quit
End If
If x.value = "+\" Then
        Console.WriteLine "Invalid edittoken."
        Quit
End If
edittoken = x.value
Console.WriteLine("Edit token retrieved: " & edittoken)
 
'Multipart variables
Dim boundary: boundary = "8G9lbpohjyr5ewclo0ho" 'Should be more random
 
'''ADODB.Stream
Dim Stream : Set Stream = CreateObject("ADODB.Stream")
'Type
Const adTypeBinary = 1
Const adTypeText = 2
'State
Const adStateClosed = 0
Const adStateOpen = 1
 
'12 Categories
Dim cats: cats = Array("Aerial", "Airport", "Buildings", "Businesses", "Churches", "Events", "Lumbermill", "Other", "People", "Schools", "Streets", "Transportation")
 
Dim cat
For Each cat In cats
	Dim ptitle: ptitle = "Category:" & cat & " images of Beaverton, Oregon"
	Console.WriteLine "Creating " & ptitle
	editpage ptitle,"[[Category:Beaverton, Oregon Historical Photo Gallery]]","[[Commons:Bots/Requests/Smallbot 4]]: Uploading images from Beaverton, Oregon Historical Photo Gallery, creating categories."
	Console.WriteLine "Created..."
Next
Console.WriteLine "Done."
 
'''''''''''''''''''''''''''''''''''
Sub wikipost(payload, attempt)
        http.open "POST","http://commons.wikimedia.org/w/api.php",False
        http.setRequestHeader "Content-Type", "application/x-www-form-urlencoded"
        http.send (payload)
        If (httpstatus() = false) Then
                If attempt < 3 Then
                        wikipost payload, attempt + 1
                Else
                        Console.WriteLine "POST FAILED|" & payload
                        'Quit, HTTP errors
                End If
        End If
End Sub
 
'Returns false if not 200 response
Function httpstatus()
        If http.status <> 200 Then
                httpstatus = False
        End If
        httpstatus = True
End Function
 
Sub nodeset(node)
        Set x= http.responseXML.selectSingleNode(node)
End Sub
 
Sub Quit
        Console.WriteLine "Quit"
        WScript.Quit
End Sub
 
Function editpage (page,text,summary)
        wikipost "format=xml&action=edit&title=" & Encode(page) & "&text=" & Encode(text) & "&summary=" & Encode(summary) &"&bot=1"& "&token=" & Encode(edittoken), 0
        nodeset "//api/edit/@result"
 
        If x Is Nothing Then
                'error
                Console.WriteLine "Edit page error->nothing->" & page
                Quit
        End If
        If x.value <> "Success" Then
                'error
                Console.WriteLine "Edit page failure." & page
                Quit
        End If
        editpage = 1
End Function
 
Sub multipartpost(source, filename, desc, comment)
        http.open "POST","http://commons.wikimedia.org/w/api.php",False
        http.setRequestHeader "Content-Type", "multipart/form-data; boundary=" & boundary
 
        Dim uploaddata
 
        Dim params: params = Array("action","format","filename","text","comment","ignorewarnings","token")
        Dim values: values = Array("upload","xml",filename,desc,comment,"1",edittoken)
        Dim count
        For count=0 To 6
                uploaddata = uploaddata & vbNewLine & "--" & boundary & vbNewLine &_
                "Content-Disposition: form-data; name=" & chr(34) & params(count) & chr(34) & vbNewLine &_
                "Content-Type: text/plain" & vbNewLine &_
                 vbNewLine & values(count)
        Next
 
        'application/octet-stream
        'image/jpg
        http.Send ConcatByteArrays( _
                ConcatByteArrays( _
                        StringToBinary(uploaddata & vbNewLine & "--" & boundary & vbNewLine &_
                                "Content-Disposition: form-data; name=" & chr(34) & "file" & chr(34) &"; filename=" &  chr(34) & filename & chr(34) & vbNewLine &_
                                "Content-Type: application/octet-stream" & vbNewLine &_
                                "Content-Transfer-Encoding: binary" & vbNewLine &_
                                vbNewLine), _
                        source), _
                StringToBinary(vbNewLine &_
                "--" & boundary & "--" & vbNewLine))
End Sub
 
'http://stackoverflow.com/questions/184574/how-to-append-binary-values-in-vbscript
Function ConcatByteArrays(bytearray1, bytearray2)
 
        ClearStream
        'Open stream and write 1st, 2nd byte array
        Stream.Open
        Stream.Type = adTypeBinary 'Binary
        Stream.Write bytearray1
        Stream.Write bytearray2
 
        Stream.Position = 0 'Reset position to read from start
 
        ConcatByteArrays = Stream.Read
        'Stream.Close
End Function
 
Sub ClearStream
        If Stream.State <> adStateClosed Then
                Stream.Close
        End If
End Sub
 
'http://www.motobit.com/tips/detpg_binasp/
Function StringToBinary(Text)
        ClearStream
 
        'Set as text stream
        Stream.Type = adTypeText
        Stream.CharSet = "us-ascii" 'can change to others
 
        'Write text to stream
        Stream.Open
        Stream.WriteText Text
 
        'Change stream to binary
        Stream.Position = 0 'Set position to 0 first
        Stream.Type = adTypeBinary
 
        'Open the stream as binary
        StringToBinary = Stream.Read
        'Stream.Close
End Function
 
'Very primitive escape
Function Encode(unencoded)
        Encode= Replace(Escape(unencoded),"+","%2B")
End Function

Fiddler[edit]

See User:Smallbot/source/Oregon Historical County Records Guide#Fiddler.