Dim fso,file,tmp,wshshell 
Set fso = CreateObject ("scripting.filesystemobject")
Set wshshell=WScript.CreateObject("wscript.shell")
Set file =fso.OpenTextFile("qq.txt") '文件目录不能为中文目录，否则不能打开
'qq.txt中书写方式：QQ号码；QQ密码 
'支持多QQ号码的自动登录，每个号码单独写一行；
'填写的密码是加密的密码，密码加密方式见VBS实现数据加密解密；
While Not file.AtEndOfStream
     tmp=Split(file.ReadLine,";")
            wshshell.Run "c:\Progra~1\Tencent\QQ2009\Bin\QQ.exe" 'QQ文件目录不能为中文目录，否则不能打开
            Set objWMIService = GetObject("winmgmts:\\" & "." & "\root\cimv2")
            Set ps = objWMIService.ExecQuery("Select * from Win32_Process Where (name='qq.exe')") 
            For Each ps2 in ps '列出系统中所有QQ正在运行的程序
                if ps2.name="QQ.EXE" or ps2.name="qq.exe" or ps2.name="QQ.exe" then
                   WScript.Sleep 1000
                   WshShell.AppActivate"QQ用户登录"
                else
                  msgbox"QQ程序启动失败!"
                 'wscript.echo "QQ程序启动失败!" 
                 'wscript.quit 
                end if 
            Next
            '发送tab键
            WScript.Sleep 200
            WshShell.AppActivate"QQ用户登录"
     wshshell.SendKeys "{tab}"
            '发送tmp(0)
            WScript.Sleep 200
            WshShell.AppActivate"QQ用户登录"
            wshshell.SendKeys tmp(0)
            '发送tab键
            WScript.Sleep 200
            WshShell.AppActivate"QQ用户登录"
     wshshell.SendKeys "{tab}"
            '发送tmp(1)
            WScript.Sleep 200
            WshShell.AppActivate"QQ用户登录"
            wshshell.SendKeys tmp2(a)
            '发送enter键
            WScript.Sleep 200
            WshShell.AppActivate"QQ用户登录"
            wshshell.SendKeys "{enter}"
Wend
'以下是QQ密码解密过程
Function tmp2(a)
a=tmp(1)
Key1=1
Key2=0
For i = 1 To Len(a)
     '从待加（解）密字符串中取出一个字符
     strChar = Mid(a, i, 1)
     '取字符的低字节和Key1进行异或运算
     bLowData = AscB(MidB(strChar, 1, 1)) Xor Key1
     '取字符的高字节和K2进行异或运算
     bHigData = AscB(MidB(strChar, 2, 1)) Xor Key2
     '将运算后的数据合成新的字符
     str = str & ChrB(bLowData) & ChrB(bHigData)
Next
tmp2 = str
'MsgBox "输入的字符串加密后为" & tmp1
End Function
复制代码