マイケルジャクソン急死真相暴露　怠慢警官・公務員のハレンチ行為紹介

twitter APIでツイッターあるキーワードで発言を検索その発言者一括フォローのスクリプト作りましたVBSソースもあるよ

Dim objIE0,sIedim xml,doc,BaseURLSet doc = CreateObject("Microsoft.XMLDOM")Dim s,u(4000),nn(4000),e(99)Set Fs = WScript.CreateObject("Scripting.FileSystemObject")Set rankHtm = Fs.OpenTextFile("twittCeleb.htm",1)Set objIEx = CreateObject("InternetExplorer.application")objIEx.Navigate "about:blank"Do While objIEx.Busy WScript.Sleep 100LoopobjIEx.Width=600 objIEx.Height=500objIEx.Visible = trueobjIEx.StatusBar = TrueobjIEx.StatusText = t_date & " htm作成中"objIEx.ToolBar = falseobjIEx.MenuBar = falseobjIEx.Document.Write "検索キー:<input name=q size=20><br>"objIEx.Document.Write "検索:<input name=start type=checkbox>"objIEx.Document.Write "終了:<input name=end type=checkbox><br>"num=0'Set xml = CreateObject("MSXML2.XMLHTTP")Set xml = CreateObject("WinHttp.WinHttpRequest.5.1")tUsername = "" 'Range("tusername")tPassword = "" 'Range("tpasswd")endd=falsedo Do WScript.Sleep 100 if objIEx.Document.all.start.checked=true then exit do if objIEx.Document.all.end.checked=true then endd=true exit do end if Loop if endd=true then exit do objIEx.Document.all.start.checked=false qq=objIEx.Document.all.q.value objIEx.Document.Write "search key=" & qq & "<br>"q_utf8=""for i= 1 to len(qq) zz=SJIStoUTF8(mid(qq,i)) 'if i>1 then ' zz=right(zz,len(zz)-1) 'end if q_utf8=q_utf8 & zznextobjIEx.Document.Write "utf8 key=" & q_utf8 & "<br>" xml.Open "POST", "http://search.twitter.com/search.json?q=" & q_utf8, "false", tUsername, tPassword xml.setRequestHeader "Content-Type", "content=text/html; charset=unicode" 'shift-jis" xml.send tResult = xml.responsetext 'you can view Twitter’s response in debug windowSet oTs2 = Fs.OpenTextFile("q\" & qq & ".txt",2,true)oTs2.writeline xml.responsetextoTs2.closemoto=xml.responseTextdo id=strmid(moto,"""id"":",",") if id="" then exit do objIEx.Document.Write "id=" & id & ":" xml.Open "POST", "http://api.twitter.com/1/friendships/create/" & id & ".xml", "false", tUsername, tPassword xml.setRequestHeader "Content-Type", "content=text/html; charset=unicode" 'shift-jis" xml.send tResult = xml.responsetext 'you can view Twitter’s response in debug window doc.loadXML (xml.responseText) If instr(doc.documentElement.selectSingleNode("error").nodeTypedValue,"not")>0 Then msg = doc.documentElement.selectSingleNode("error").nodeTypedValue objIEx.Document.write "エラー:" + "[" + msg + "]" else objIEx.Document.write "created" end if objIEx.Document.write "<br>"loop doc.loadXML (xml.responseText)' objIEx.Document.Write doc.documentElement.selectSingleNode("error").nodeTypedValue'if instr(doc.documentElement.selectSingleNode("error").nodeTypedValue,"not")>0 then' exit for'end if' objIEx.Document.Write "<br>"loopobjIEx.Document.Write "done"Set xml = NothingFunction strmid(org,mae,usiro) pos = InStr(org, mae) If pos > 0 Then strmid = Right(org, Len(org) - pos - Len(mae) + 1) org = strmid pos = InStr(strmid, usiro) If usiro = "" Then' strmid = "" Else If pos > 0 Then strmid = Left(strmid, pos - 1) End If End If Else strmid = "" End IfEnd FunctionFunction SJIStoUTF8(strSJIS) strUNICODE = ASCW(strSJIS) 'ASCWでユニコードにする 'コードを２進にしてワークに代入する strWORK2 = HEX16toSTR2(HEX(strUNICODE)) '切り取って、UTF8の２進数を作成する 'xxxx xxxx xxxx xxxx を下記に割り当てる '1110xxxx 10xxxxxx 10xxxxxx strUTF8CODE = "1110" & Mid(strWORK2, 1, 4) strUTF8CODE = strUTF8CODE & "10" & Mid(strWORK2, 5, 6) strUTF8CODE = strUTF8CODE & "10" & Mid(strWORK2, 11, 6) '作成した２進数を１６進数に戻す strWORK16 = STR2toHEX16(strUTF8CODE) '%を付けて格納 strRET = "" 'リターン値を初期化 strRET = strRET & "%" & Mid(strWORK16, 1, 2) '%を付けた文字列を作成 strRET = strRET & "%" & Mid(strWORK16, 3, 2) strRET = strRET & "%" & Mid(strWORK16, 5, 2) 'リターン値を代入 SJIStoUTF8 = strRETEnd Function'HEX16進文字列を受け取り2進数文字列を返すFunction HEX16toSTR2(strHEX) Dim n 'ループカウンタ Dim i 'ループのカウンタ Dim n8421 '8 4 2 1の数値計算用 Dim str2STR Dim nCHK str2STR = "" '結果のエリアを初期化する '文字数分ループする For n = 1 To Len(strHEX) On Error Resume Next 'エラー発生時次の行へ nCHK = 0 '0で初期化 nCHK = CInt("&h" & Mid(strHEX, n, 1)) 'n文字目を数値変換 On Error Goto 0 'エラー処理を通常に戻す n8421 = 8 '初期値に８を代入する(上からチェックしたいので) For i = 1 To 4 '４回まわるよ If (nCHK And n8421) = 0 Then 'Andでビットをチェックする str2STR = str2STR & "0" 'ビットは立ってないよ Else str2STR = str2STR & "1" 'ビットは立ってるよ End If '次のビットをチェックしたいので２で割る n8421 = n8421 / 2 Next Next 'リターン値をセットして終了 HEX16toSTR2 = str2STREnd Function'2進文字列を受け取り16進文字列を返すFunction STR2toHEX16(str2) Dim strHEX Dim n 'ループカウンタ Dim i 'ループのカウンタ Dim n8421 '8 4 2 1の数値計算用 Dim nBYTE '頭４文字単位かチェックする n = Len(str2) Mod 4 '足りない文字数を計算する If n <> 0 Then str2 = String(4 - n, "0") & str2 '頭に文字０を追加する End If strHEX = "" '結果のエリアを初期化する '文字数分ループする For n = 1 To Len(str2) Step 4 '４文字(1バイト)単位にループを作る n8421 = 8 '初期値に８を代入する(上から計算したいので) nBYTE = 0 '1バイト計算用変数を初期化 For i = 0 To 3 '４回まわるよ(4ビット分) 'ビットが立っているかチェックする If Mid(str2, n + i, 1) = "1" Then nBYTE = nBYTE + n8421 'ビットに対応した数値を＋する End If '次のビットを計算したいので２で割る n8421 = n8421 / 2 Next '計算して、１倍との数値が完成したので１６進文字にしてセットする strHEX = strHEX & Hex(nBYTE) Next 'リターン値をセットして関数を抜ける STR2toHEX16 = strHEXEnd Function