用VBScript帮朋友写的一个用以内网投票的程序

      近日应朋友请求，用VBScript写了一个投票小程序，有些东西平时没用过还真不知道，为防止遗忘，就在Blog里记一下，好记性不如烂笔头嘛。

Function randNum()
  result = -1
  For ii=0 To 10
    While (result<1 or result>3)
      result = round(( Rnd() * 30 / 10 ))
    WEnd
  Next
  randNum = result
End Function

Function RndNumber(min, max)
  Randomize()
  result = -1
  While (result<min Or result>max)
    result = Int( Rnd() * (max - min + 1) ) + min 
  Wend
  RndNumber = result
End Function

Function ChangeIP(ip, netMask)
  '设置IP 
  'strIPAddress=Array("192.168.1.43")
  strIPAddress=Array(ip)

  '设置子网掩码 
  strSubnetMask=Array(netMask) 

  '设置网关 
  'DefaultIPGateway=Array("192.168.1.1") 

  '设置跃点数 
  'GatewayCostMetric=Array("1") 

  '设置DNS服务器 
  'DNSServer = Array("61.139.44.38", "61.139.2.69") 

  strComputer="."     '本机
  Set objWMIService=GetObject("winmgmts:\\" & strComputer & "\root\cimv2") 
  Set colNetAdapters=objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration where IPEnabled=TRUE") 

  For Each objNetAdapter in colNetAdapters 
    '设置IP和子网掩码
    errEnable=objNetAdapter.EnableStatic(strIPAddress, strSubnetMask)
    '设置网关和跃点数
    'errEnable=objNetAdapter.SetGateways(DefaultIPGateway,GatewayCostMetric)
    '设置DNS 
    'errEnable=objNetAdapter.SetDNSServerSearchOrder(DNSServer)
  Next
  ChangeIP = true
End Function

Function makeQuery
  Dim str

  str = ""
  For ii=1 To 10
    str = str & ii & "=" 
    If ii=4 Then 
      str = str & "11"
    Else 
      str = str & (randNum() + (ii - 1) * 3)
    End If
    If ii<10 Then str = str & "&"
  Next
  str = str & "&sss.x=150&sss.y=35"
  makeQuery = str
End Function
'MsgBox makeQuery

Dim xmlhttp

Function SendRequest(url, queryString)
  'define vars
  
  'url = "http://sheng.iteye.com"
  'MsgBox "URL = " & url & "?" & queryString
  txtfile.WriteLine( queryString )
  'Exit Function 

  'make request
  xmlhttp.open "POST", url, False
  xmlhttp.setRequestHeader "Content-length", Len(queryString)
  xmlhttp.setRequestHeader "Accept","image/gif, image/x-xbitmap, image/jpeg, image/pjpeg, application/x-shockwave-flash, */*"
  xmlhttp.setRequestHeader "Referer","http://X.X.X.X/fjltpoll/poll_intro.asp"
  xmlhttp.setRequestHeader "Accept-Language","zh-cn"
  xmlhttp.setRequestHeader "Content-Type","application/x-www-form-urlencoded"
  xmlhttp.setRequestHeader "Accept-Encoding","gzip, deflate"
  xmlhttp.setRequestHeader "User-Agent","Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1; SV1; Maxthon; .NET CLR 1.1.4322)"
  xmlhttp.setRequestHeader "Host","X.X.X.X"
  xmlhttp.setRequestHeader "Connection","Keep-Alive"
  xmlhttp.setRequestHeader "Cache-Control","no-cache"
  xmlhttp.setRequestHeader "Cookie","ASPSESSIONIDAQADASTQ=PJNHMBADPFKJBHDNBJGELLEL"
  xmlhttp.setRequestHeader "Content-Type","text/html;charset=GB2312"
  xmlhttp.send queryString
  'wait for response
  xmlhttp.waitForResponse()
  'if status is 200, then it's OK
  if xmlhttp.status = 200 then
    'WScript.Echo xmlhttp.responseText
    txtfile.WriteLine( Bytes2BSTR(xmlhttp.responseBody ))
  else
    'popup bad response, or just omit to end
    'WScript.Echo("bad response")
    txtfile.WriteLine( "bad response" )
  end if
  'destroy objects. I'm not sure this is necessary

  'Set xmlhttp = Nothing
End Function

Dim url
url = "http://X.X.X.X/fjltpoll/vote.asp"

Dim logFile, fso, txtfile
logFile = "C:\vote_log.txt"

Function Bytes2BSTR( vIn )   
  Dim strReturn   
  strReturn = ""   
    
  For i =1 To LenB(vIn)   
    ThisCharCode = AscB(MidB(vIn,i,1))   
    If ThisCharCode < &H80 Then   
      strReturn = strReturn & Chr(ThisCharCode)   
    Else
      NextCharCode = AscB(MidB(vIn,i+1,1))   
      strReturn = strReturn & Chr(CLng(ThisCharCode) * &H100 + CInt(NextCharCode))
      i = i + 1   
    End If
  Next   
  Bytes2BSTR   =   strReturn   
End Function 

Sub InitObject
  Set fso = CreateObject("Scripting.FileSystemObject")
  Set txtfile = fso.OpenTextFile(logFile, 2, True)
  Set xmlhttp = CreateObject("MSXML2.ServerXMLHTTP")
End Sub

Sub ReleaseObject
  txtfile.close
  Set txtfile = Nothing
  Set fso     = Nothing
  Set xmlhttp = Nothing
End Sub

Function Vote()
  Dim subIPs, sleepTime
  MsgBox "开始"
  InitObject

  subIPs = Split(IPs, ",")
  For ii=0 To UBound(subIPs)
    IP = IPprefix & subIPs(ii)                                        '生成IP
    sleepTime = RndNumber(sleepTimeMin, sleepTimeMax) * 1000          '生成间隔时间
    txtfile.WriteLine( "IP=" & IP & ", SleepTime=" & sleepTime & " ms")  '记录日志

    ChangeIP IP, netMask
    qStr = makeQuery()
    SendRequest url, qStr
    WScript.sleep( sleepTime )
  Next
  ReleaseObject
  MsgBox "结束"
End Function





'==*************************************************==
'   下面的参数可以更改 
'==-------------------------------------------------==

Dim IPprefix, fromIP, toIP, netMask, IPs
Dim sleepTimeMin, sleepTimeMax       '最小/最大间隔时间（以秒计）
IPprefix = "X.X.32."              'IP前半部分
'fromIP   = 1                        '开始的IP地址
'toIP     = 5                        '结束的IP地址
IPs = "1,3,2,5,4"                    'IP序列
netMask  = "255.255.248.0"           '子网掩码

sleepTimeMin = 10
sleepTimeMax = 60

'开始
Vote()