命令行方式实现QQ自动登录

上一次写过一篇VB制作QQ自动登录器的日志，介绍用得是模拟键盘输入的方式实现QQ的自动登录。这种方式有一种缺陷，就是必须保持输入焦点的正确，否则很容易就打乱了程序的执行过程，造成无法登录。特别是一开机就运行该程序，然后该程序去调用QQ的时候，Win API Winexec执行特慢，导致程序跟不上QQ，输入焦点也错了。后来在网上又发现了一种用QQ命令行的方式来实现自动登录的，这种方式明显更好用。该命令行的格式为“QQ应用程序路径 /START QQUIN:QQ号码 PWDHASH:Base64(MD5(QQ密码)) /STAT:登录模式”。

        QQ应用程序的路径我们可以在注册表下面找到，而需要注意的是QQ密码必须是经过MD5加密过的，再用Base64编码一次。登录模式则有40和41两种，40表示隐身登录，41表示正常登录。了解了命令行的格式后我们就直接调用Win API Winexec就可以实现QQ的自动登录了。下面给出实现代码：

m_QQ_AutoLogin模块：

Option Explicit
Public Declare Function RegOpenKeyEx Lib "advapi32.dll" Alias "RegOpenKeyExA" (ByVal hKey As Long, ByVal lpSubKey As String, ByVal ulOptions As Long, ByVal samDesired As Long, phkResult As Long) As Long
Public Declare Function RegQueryValueEx Lib "advapi32.dll" Alias "RegQueryValueExA" (ByVal hKey As Long, ByVal lpValueName As String, ByVal lpReserved As Long, lpType As Long, lpData As Any, lpcbData As Long) As Long         ' Note that if you declare the lpData parameter as String, you must pass it By Value.
Public Declare Function RegCloseKey Lib "advapi32.dll" (ByVal hKey As Long) As Long
Public Declare Function PathFileExists Lib "shlwapi.dll" Alias "PathFileExistsA" (ByVal szPath As String) As Long
Private Declare Function WinExec Lib "kernel32" (ByVal lpCmdLine As String, ByVal nCmdShow As Long) As Long

Public Const HKEY_LOCAL_MACHINE = &H80000002
Public Const KEY_ALL_ACCESS = &H3F
Public Const ERROR_SUCCESS = 0&

Public conn As ADODB.Connection   'conn为连接
Public rs As ADODB.Recordset    'rs为记录集

'连接数据库
Function QQ_DB_Connect() As Boolean
    Dim strQQDBPath As String
    
    QQ_DB_Connect = False
    
    If Right(App.Path, 1) = "" Then  '获取数据库的路径
        strQQDBPath = App.Path & "QQData.mdb"
    Else
        strQQDBPath = App.Path & "QQData.mdb"
    End If
    
    If PathFileExists(strQQDBPath) = 0 Then
        MsgBox "在当前应用程序目录下找不到数据库文件！", vbInformation Or vbOKOnly, "QQ自动登录器"
        Exit Function
    End If
    
    'MsgBox QQDBPath
    Set conn = New ADODB.Connection
    If conn.State = adStateOpen And Not IsEmpty(adStateOpen) Then conn.Close
    conn.ConnectionString = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strQQDBPath & ";Jet OLEDB:Database Password=QQDATA"
    conn.CursorLocation = adUseClient
    conn.Open
    QQ_DB_Connect = True
End Function

'断开与数据库的连接
Function QQ_DB_Deconnetion()
    If conn.State = adStateOpen Then conn.Close
    Set conn = Nothing
End Function

'添加QQ号码信息函数
Function QQ_DB_Add(strNum As String, strPwd As String) As Boolean
    Dim strSql As String
    
    If QQ_DB_Find(strNum) Then
        QQ_DB_Add = False
    Else
        strSql = "insert into QQDataTable(QQ_NUM,QQ_PWD) values('" & strNum & "','" & strPwd & "')"
        conn.Execute strSql
        QQ_DB_Add = True
    End If
End Function

'修改QQ号码信息函数
Function QQ_DB_Edit(strNum As String, strPwd As String) As Boolean
    Dim nID As Long, strSql As String
    
    nID = QQ_DB_Find(strNum)
    If nID Then
        strSql = "Update QQDataTable set QQ_NUM='" & strNum & "',QQ_PWD='" & strPwd & "' where ID=" & nID
        conn.Execute strSql
        QQ_DB_Edit = True
    Else
        QQ_DB_Edit = False
    End If
End Function

'获取指定的QQ号码记录的ID
Function QQ_DB_Find(strNum As String) As Long
    Dim strSql As String
    
    strSql = "select * from QQDataTable where QQ_NUM='" & strNum & "'"
    Set rs = New ADODB.Recordset
    rs.Open strSql, conn
    If rs.RecordCount > 0 Then
        QQ_DB_Find = rs.Fields("ID")
    Else
        QQ_DB_Find = 0
    End If
    rs.Close
    Set rs = Nothing
End Function

'获取指定ID记录的信息
Function QQ_DB_Get(nID As Long, strNum As String, strPwd As String) As Boolean
    Dim strSql As String
    
    strSql = "select * from QQDataTable where ID=" & nID
    Set rs = New ADODB.Recordset
    rs.Open strSql, conn
    If rs.RecordCount > 0 Then
        strNum = rs.Fields("QQ_NUM")
        strPwd = rs.Fields("QQ_PWD")
        QQ_DB_Get = True
    Else
        QQ_DB_Get = False
    End If
    rs.Close
    Set rs = Nothing
End Function

'更新QQ号码列表函数
Function QQ_DB_UpdataUserList(lvListView As ListView)
    Dim strSql As String
    Dim strNum As String
    
    lvListView.ListItems.Clear
    strSql = "select * from QQDataTable"
    Set rs = New ADODB.Recordset
    rs.Open strSql, conn
    Do While Not rs.EOF
        strNum = rs.Fields("QQ_NUM")
        Call lvListView.ListItems.Add(, , strNum, 0, 1)
        rs.MoveNext
    Loop
    rs.Close
    Set rs = Nothing
End Function

'删除QQ信息函数
Function QQ_DB_Del(strNum As String) As Boolean
    Dim strSql As String
    
    If QQ_DB_Find(strNum) Then
        strSql = "delete * from QQDataTable where QQ_NUM = '" & strNum & "'"
        conn.Execute strSql
        QQ_DB_Del = True
    Else
        QQ_DB_Del = False
    End If
End Function

'获取QQ应用程序安装路径
Function QQ_DB_GetQQAppPath() As String
    Dim hKey As Long, strQQAppPath As String, lngQQAppPathLen As Long
    
    QQ_DB_GetQQAppPath = ""  '初始化函数返回值
    
    If RegOpenKeyEx(HKEY_LOCAL_MACHINE, "SOFTWARETencentQQ", 0, KEY_ALL_ACCESS, hKey) <> ERROR_SUCCESS Then  '到注册表去获取QQ安装目录
        Exit Function  '失败返回
    End If
    
    strQQAppPath = String(256, 0)
    lngQQAppPathLen = Len(strQQAppPath)
    If RegQueryValueEx(hKey, "Install", 0, 0, ByVal strQQAppPath, lngQQAppPathLen) <> ERROR_SUCCESS Then
        Call RegCloseKey(hKey)
        Exit Function  '失败返回
    End If

    Call RegCloseKey(hKey)
    
    strQQAppPath = Left(strQQAppPath, InStr(strQQAppPath, Chr(0)) - 1)
    If Right(strQQAppPath, 1) = "" Then
        strQQAppPath = strQQAppPath & "QQ.exe"
    Else
        strQQAppPath = strQQAppPath & "QQ.exe"
    End If
    QQ_DB_GetQQAppPath = strQQAppPath
End Function

'QQ命令行密码加密函数
Function QQ_DB_Pwdhash(strPwd As String) As String
    Dim bytMD5Bytes() As Byte, bytBase64Bytes() As Byte
    
    bytMD5Bytes() = MyMD5(strPwd)
    bytBase64Bytes() = Base64_Encode(bytMD5Bytes())
    QQ_DB_Pwdhash = StrConv(bytBase64Bytes(), vbUnicode)
End Function

'QQ命令行自动登录函数
Function QQ_AutoLogin(strNum As String, intLoginMode As Integer) As Boolean
    Dim strPwd As String, lngID As Long
    Dim strQQAppPath As String, strQQAppCmd As String
    
    lngID = QQ_DB_Find(strNum)
    If lngID Then
        If QQ_DB_Get(lngID, strNum, strPwd) Then
            strPwd = QQ_DB_Pwdhash(strPwd)  '经命令行密码加密函数加密
            strQQAppPath = QQ_DB_GetQQAppPath()      '获取QQ应用程序安装路径
            strQQAppCmd = strQQAppPath & " /START QQUIN:" & strNum & " PWDHASH:" & strPwd & " /STAT:" & intLoginMode  '40隐身登录，41正常登录
            Call WinExec(strQQAppCmd, 1)  '运行QQ应用程序
        End If
    Else
        MsgBox "该QQ号码未设置密码信息，请先设置！", vbInformation + vbOKOnly, "QQ自动登录器"
    End If
End Function

m_QQ_MD5模块：

Option Explicit

Private m_lOnBits(30)
Private m_l2Power(30)
Private Const BITS_TO_A_BYTE = 8
Private Const BYTES_TO_A_WORD = 4
Private Const BITS_TO_A_WORD = 32

'MD5加密函数,返回MD5加密串(返回Byte数组，16字节)
Public Function MyMD5(strMessage As String) As Byte()
    Dim strMD5Hash As String, i As Long
    Dim btyMD5Bytes(0 To 15) As Byte
    
    strMD5Hash = MD5(strMessage, 32)
    For i = 0 To 31 Step 2
        btyMD5Bytes(i / 2) = HexToDec(Mid(strMD5Hash, i + 1, 2))
    Next
    
    'Open "C:MD5.txt" For Binary As #1
    'Put #1, , btyMD5Bytes()
    'Close #1
    
    MyMD5 = btyMD5Bytes()
End Function

'16进制字符串转换10进制数字函数
Public Function HexToDec(ByVal strHex As String) As Long
    HexToDec = "&h" & strHex
End Function

'下面是别人写的函数
Private Function md5_F(X, Y, z)
md5_F = (X And Y) Or ((Not X) And z)
End Function

Private Function md5_G(X, Y, z)
md5_G = (X And z) Or (Y And (Not z))
End Function

Private Function md5_H(X, Y, z)
md5_H = (X Xor Y Xor z)
End Function

Private Function md5_I(X, Y, z)
md5_I = (Y Xor (X Or (Not z)))
End Function

Private Sub md5_FF(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_F(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub

Private Sub md5_GG(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_G(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub

Private Sub md5_HH(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_H(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub

Private Sub md5_II(a, b, c, d, X, s, ac)
a = AddUnsigned(a, AddUnsigned(AddUnsigned(md5_I(b, c, d), X), ac))
a = RotateLeft(a, s)
a = AddUnsigned(a, b)
End Sub

Private Function ConvertToWordArray(sMessage)
Dim lMessageLength
Dim lNumberOfWords
Dim lWordArray()
Dim lBytePosition
Dim lByteCount
Dim lWordCount

Const MODULUS_BITS = 512
Const CONGRUENT_BITS = 448

lMessageLength = Len(sMessage)

lNumberOfWords = (((lMessageLength + ((MODULUS_BITS - CONGRUENT_BITS)  BITS_TO_A_BYTE))  (MODULUS_BITS  BITS_TO_A_BYTE)) + 1) * (MODULUS_BITS  BITS_TO_A_WORD)
ReDim lWordArray(lNumberOfWords - 1)

lBytePosition = 0
lByteCount = 0
Do Until lByteCount >= lMessageLength
lWordCount = lByteCount  BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE
lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(Asc(Mid(sMessage, lByteCount + 1, 1)), lBytePosition)
lByteCount = lByteCount + 1
Loop

lWordCount = lByteCount  BYTES_TO_A_WORD
lBytePosition = (lByteCount Mod BYTES_TO_A_WORD) * BITS_TO_A_BYTE

lWordArray(lWordCount) = lWordArray(lWordCount) Or LShift(&H80, lBytePosition)

lWordArray(lNumberOfWords - 2) = LShift(lMessageLength, 3)
lWordArray(lNumberOfWords - 1) = RShift(lMessageLength, 29)

ConvertToWordArray = lWordArray
End Function

Private Function WordToHex(lValue)
Dim lByte
Dim lCount

For lCount = 0 To 3
lByte = RShift(lValue, lCount * BITS_TO_A_BYTE) And m_lOnBits(BITS_TO_A_BYTE - 1)
WordToHex = WordToHex & Right("0" & Hex(lByte), 2)
Next
End Function

Public Function MD5(sMessage, stype)
m_lOnBits(0) = CLng(1)
m_lOnBits(1) = CLng(3)
m_lOnBits(2) = CLng(7)
m_lOnBits(3) = CLng(15)
m_lOnBits(4) = CLng(31)
m_lOnBits(5) = CLng(63)
m_lOnBits(6) = CLng(127)
m_lOnBits(7) = CLng(255)
m_lOnBits(8) = CLng(511)
m_lOnBits(9) = CLng(1023)
m_lOnBits(10) = CLng(2047)
m_lOnBits(11) = CLng(4095)
m_lOnBits(12) = CLng(8191)
m_lOnBits(13) = CLng(16383)
m_lOnBits(14) = CLng(32767)
m_lOnBits(15) = CLng(65535)
m_lOnBits(16) = CLng(131071)
m_lOnBits(17) = CLng(262143)
m_lOnBits(18) = CLng(524287)
m_lOnBits(19) = CLng(1048575)
m_lOnBits(20) = CLng(2097151)
m_lOnBits(21) = CLng(4194303)
m_lOnBits(22) = CLng(8388607)
m_lOnBits(23) = CLng(16777215)
m_lOnBits(24) = CLng(33554431)
m_lOnBits(25) = CLng(67108863)
m_lOnBits(26) = CLng(134217727)
m_lOnBits(27) = CLng(268435455)
m_lOnBits(28) = CLng(536870911)
m_lOnBits(29) = CLng(1073741823)
m_lOnBits(30) = CLng(2147483647)

m_l2Power(0) = CLng(1)
m_l2Power(1) = CLng(2)
m_l2Power(2) = CLng(4)
m_l2Power(3) = CLng(8)
m_l2Power(4) = CLng(16)
m_l2Power(5) = CLng(32)
m_l2Power(6) = CLng(64)
m_l2Power(7) = CLng(128)
m_l2Power(8) = CLng(256)
m_l2Power(9) = CLng(512)
m_l2Power(10) = CLng(1024)
m_l2Power(11) = CLng(2048)
m_l2Power(12) = CLng(4096)
m_l2Power(13) = CLng(8192)
m_l2Power(14) = CLng(16384)
m_l2Power(15) = CLng(32768)
m_l2Power(16) = CLng(65536)
m_l2Power(17) = CLng(131072)
m_l2Power(18) = CLng(262144)
m_l2Power(19) = CLng(524288)
m_l2Power(20) = CLng(1048576)
m_l2Power(21) = CLng(2097152)
m_l2Power(22) = CLng(4194304)
m_l2Power(23) = CLng(8388608)
m_l2Power(24) = CLng(16777216)
m_l2Power(25) = CLng(33554432)
m_l2Power(26) = CLng(67108864)
m_l2Power(27) = CLng(134217728)
m_l2Power(28) = CLng(268435456)
m_l2Power(29) = CLng(536870912)
m_l2Power(30) = CLng(1073741824)

Dim X
Dim k
Dim AA
Dim BB
Dim CC
Dim DD
Dim a
Dim b
Dim c
Dim d

Const S11 = 7
Const S12 = 12
Const S13 = 17
Const S14 = 22
Const S21 = 5
Const S22 = 9
Const S23 = 14
Const S24 = 20
Const S31 = 4
Const S32 = 11
Const S33 = 16
Const S34 = 23
Const S41 = 6
Const S42 = 10
Const S43 = 15
Const S44 = 21

X = ConvertToWordArray(sMessage)

a = &H67452301
b = &HEFCDAB89
c = &H98BADCFE
d = &H10325476

For k = 0 To UBound(X) Step 16
AA = a
BB = b
CC = c
DD = d

md5_FF a, b, c, d, X(k + 0), S11, &HD76AA478
md5_FF d, a, b, c, X(k + 1), S12, &HE8C7B756
md5_FF c, d, a, b, X(k + 2), S13, &H242070DB
md5_FF b, c, d, a, X(k + 3), S14, &HC1BDCEEE
md5_FF a, b, c, d, X(k + 4), S11, &HF57C0FAF
md5_FF d, a, b, c, X(k + 5), S12, &H4787C62A
md5_FF c, d, a, b, X(k + 6), S13, &HA8304613
md5_FF b, c, d, a, X(k + 7), S14, &HFD469501
md5_FF a, b, c, d, X(k + 8), S11, &H698098D8
md5_FF d, a, b, c, X(k + 9), S12, &H8B44F7AF
md5_FF c, d, a, b, X(k + 10), S13, &HFFFF5BB1
md5_FF b, c, d, a, X(k + 11), S14, &H895CD7BE
md5_FF a, b, c, d, X(k + 12), S11, &H6B901122
md5_FF d, a, b, c, X(k + 13), S12, &HFD987193
md5_FF c, d, a, b, X(k + 14), S13, &HA679438E
md5_FF b, c, d, a, X(k + 15), S14, &H49B40821

md5_GG a, b, c, d, X(k + 1), S21, &HF61E2562
md5_GG d, a, b, c, X(k + 6), S22, &HC040B340
md5_GG c, d, a, b, X(k + 11), S23, &H265E5A51
md5_GG b, c, d, a, X(k + 0), S24, &HE9B6C7AA
md5_GG a, b, c, d, X(k + 5), S21, &HD62F105D
md5_GG d, a, b, c, X(k + 10), S22, &H2441453
md5_GG c, d, a, b, X(k + 15), S23, &HD8A1E681
md5_GG b, c, d, a, X(k + 4), S24, &HE7D3FBC8
md5_GG a, b, c, d, X(k + 9), S21, &H21E1CDE6
md5_GG d, a, b, c, X(k + 14), S22, &HC33707D6
md5_GG c, d, a, b, X(k + 3), S23, &HF4D50D87
md5_GG b, c, d, a, X(k + 8), S24, &H455A14ED
md5_GG a, b, c, d, X(k + 13), S21, &HA9E3E905
md5_GG d, a, b, c, X(k + 2), S22, &HFCEFA3F8
md5_GG c, d, a, b, X(k + 7), S23, &H676F02D9
md5_GG b, c, d, a, X(k + 12), S24, &H8D2A4C8A

md5_HH a, b, c, d, X(k + 5), S31, &HFFFA3942
md5_HH d, a, b, c, X(k + 8), S32, &H8771F681
md5_HH c, d, a, b, X(k + 11), S33, &H6D9D6122
md5_HH b, c, d, a, X(k + 14), S34, &HFDE5380C
md5_HH a, b, c, d, X(k + 1), S31, &HA4BEEA44
md5_HH d, a, b, c, X(k + 4), S32, &H4BDECFA9
md5_HH c, d, a, b, X(k + 7), S33, &HF6BB4B60
md5_HH b, c, d, a, X(k + 10), S34, &HBEBFBC70
md5_HH a, b, c, d, X(k + 13), S31, &H289B7EC6
md5_HH d, a, b, c, X(k + 0), S32, &HEAA127FA
md5_HH c, d, a, b, X(k + 3), S33, &HD4EF3085
md5_HH b, c, d, a, X(k + 6), S34, &H4881D05
md5_HH a, b, c, d, X(k + 9), S31, &HD9D4D039
md5_HH d, a, b, c, X(k + 12), S32, &HE6DB99E5
md5_HH c, d, a, b, X(k + 15), S33, &H1FA27CF8
md5_HH b, c, d, a, X(k + 2), S34, &HC4AC5665

md5_II a, b, c, d, X(k + 0), S41, &HF4292244
md5_II d, a, b, c, X(k + 7), S42, &H432AFF97
md5_II c, d, a, b, X(k + 14), S43, &HAB9423A7
md5_II b, c, d, a, X(k + 5), S44, &HFC93A039
md5_II a, b, c, d, X(k + 12), S41, &H655B59C3
md5_II d, a, b, c, X(k + 3), S42, &H8F0CCC92
md5_II c, d, a, b, X(k + 10), S43, &HFFEFF47D
md5_II b, c, d, a, X(k + 1), S44, &H85845DD1
md5_II a, b, c, d, X(k + 8), S41, &H6FA87E4F
md5_II d, a, b, c, X(k + 15), S42, &HFE2CE6E0
md5_II c, d, a, b, X(k + 6), S43, &HA3014314
md5_II b, c, d, a, X(k + 13), S44, &H4E0811A1
md5_II a, b, c, d, X(k + 4), S41, &HF7537E82
md5_II d, a, b, c, X(k + 11), S42, &HBD3AF235
md5_II c, d, a, b, X(k + 2), S43, &H2AD7D2BB
md5_II b, c, d, a, X(k + 9), S44, &HEB86D391

a = AddUnsigned(a, AA)
b = AddUnsigned(b, BB)
c = AddUnsigned(c, CC)
d = AddUnsigned(d, DD)
Next

If stype = 32 Then
    MD5 = LCase(WordToHex(a) & WordToHex(b) & WordToHex(c) & WordToHex(d))
Else
    MD5 = LCase(WordToHex(b) & WordToHex(c))
End If

End Function

Private Function AddUnsigned(lX, lY)
Dim lX4
Dim lY4
Dim lX8
Dim lY8
Dim lResult

lX8 = lX And &H80000000
lY8 = lY And &H80000000
lX4 = lX And &H40000000
lY4 = lY And &H40000000

lResult = (lX And &H3FFFFFFF) + (lY And &H3FFFFFFF)

If lX4 And lY4 Then
lResult = lResult Xor &H80000000 Xor lX8 Xor lY8
ElseIf lX4 Or lY4 Then
If lResult And &H40000000 Then
lResult = lResult Xor &HC0000000 Xor lX8 Xor lY8
Else
lResult = lResult Xor &H40000000 Xor lX8 Xor lY8
End If
Else
lResult = lResult Xor lX8 Xor lY8
End If

AddUnsigned = lResult
End Function

Private Function LShift(lValue, iShiftBits)
If iShiftBits = 0 Then
LShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And 1 Then
LShift = &H80000000
Else
LShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

If (lValue And m_l2Power(31 - iShiftBits)) Then
LShift = ((lValue And m_lOnBits(31 - (iShiftBits + 1))) * m_l2Power(iShiftBits)) Or &H80000000
Else
LShift = ((lValue And m_lOnBits(31 - iShiftBits)) * m_l2Power(iShiftBits))
End If
End Function

Private Function RShift(lValue, iShiftBits)
If iShiftBits = 0 Then
RShift = lValue
Exit Function
ElseIf iShiftBits = 31 Then
If lValue And &H80000000 Then
RShift = 1
Else
RShift = 0
End If
Exit Function
ElseIf iShiftBits < 0 Or iShiftBits > 31 Then
Err.Raise 6
End If

RShift = (lValue And &H7FFFFFFE)  m_l2Power(iShiftBits)

If (lValue And &H80000000) Then
RShift = (RShift Or (&H40000000  m_l2Power(iShiftBits - 1)))
End If
End Function

Private Function RotateLeft(lValue, iShiftBits)
RotateLeft = LShift(lValue, iShiftBits) Or RShift(lValue, (32 - iShiftBits))
End Function