命令行方式实现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

m_Base64模块：

Option   Explicit
' 除以2的一次方是右移一位
' 乘以2的一次方是左移一位
' (bytInText(i) And &HFC)  (2 ^ 2)
' 第一个字节的内容And运算0xFC(11111100)(取左边6位)，再除以2的二次方(右移2位)
' (bytInText(i) And &H3) * (2 ^ 4) Or (bytInText(i + 1) And &HF0)  (2 ^ 4)
' 第一个字节的内容And运算0x03(00000011)(取右边2位)，再乘以2的四次方(左移4位)
' 第二个字节的内容And运算0xF0(11110000)(取左边4位)，再除以2的四次方(右移4位)
' 两个结果再Or运算
' (bytInText(i + 1) And &HF) * (2 ^ 2) + (bytInText(i + 2) And &HC0)  (2 ^ 6)
' 第二个字节的内容And运算0x0F(00001111)(取右边4位)，再乘以2的二次方(左移2位)
' 第三个字节的内容And运算0xC0(11000000)(取左边2位)，再除以2的六次方(右移6位)
' 两个结果再Or运算
' bytInText(i + 2) And &H3F
' 第三个字节的内容And运算0x3F(00111111)(取右边6位)
        
' Base64编码函数
Public   Function  Base64_Encode(bytInText()  As   Byte )  As   Byte ()
     Dim  Base64EncodeTable()  As   Byte
     Dim  lngInTextLen  As   Long , lngMod  As   Long , i  As   Long
     Dim  bytEncode()  As   Byte , lngEncodeLen  As   Long
    
    Base64_Encode  =   Chr ( 0 )   ' 初始化函数返回值
    
    Base64EncodeTable()  =   " ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/= "   ' 初始化Base64编码表
    Base64EncodeTable()  =   StrConv (Base64EncodeTable(), vbFromUnicode)   ' 转换为ANSI编码
    
     If   LBound (bytInText)  <>   0   Then   Exit Function    ' bytInText数组下标不从零开始则出错返回
    
    lngInTextLen  =   UBound (bytInText)  -   LBound (bytInText)  +   1    ' 计算bytInText数组长度
    
    lngMod  =  lngInTextLen  Mod   3   ' 取模3后的余数(结果只有0、1、2三种情况)
     If  lngMod  =   0   Then
        lngEncodeLen  =  lngInTextLen  /   3   *   4    ' 求编码后的长度
        lngInTextLen  =  lngInTextLen  /   3   *   3    ' 取3的整数倍
     ElseIf  lngMod  =   1   Then
        lngEncodeLen  =  (lngInTextLen  +   2 )  /   3   *   4    ' 求编码后的长度
        lngInTextLen  =  ((lngInTextLen  +   2 )  /   3   -   1 )  *   3   ' 取3的整数倍
     ElseIf  lngMod  =   2   Then
        lngEncodeLen  =  (lngInTextLen  +   1 )  /   3   *   4    ' 求编码后的长度
        lngInTextLen  =  ((lngInTextLen  +   1 )  /   3   -   1 )  *   3   ' 取3的整数倍
     End   If
    
     ' MsgBox "编码后的长度为" & lngEncodeLen & "字节！"
     ' MsgBox "3的整数倍为" & lngInTextLen
    
     ReDim  bytEncode( 0   To  lngEncodeLen  -   1 )  ' 重新定义编码缓冲区
    lngEncodeLen  =   0    ' 初始化编码长度计数
    
     For  i  =   0   To  lngInTextLen  -   1   Step   3
        bytEncode(lngEncodeLen)  =  Base64EncodeTable((bytInText(i)  And   & HFC)  ( 2   ^   2 ))
        bytEncode(lngEncodeLen  +   1 )  =  Base64EncodeTable((bytInText(i)  And   & H3)  *  ( 2   ^   4 )  Or  (bytInText(i  +   1 )  And   & HF0)  ( 2   ^   4 ))
        bytEncode(lngEncodeLen  +   2 )  =  Base64EncodeTable((bytInText(i  +   1 )  And   & HF)  *  ( 2   ^   2 )  Or  (bytInText(i  +   2 )  And   & HC0)  ( 2   ^   6 ))
        bytEncode(lngEncodeLen  +   3 )  =  Base64EncodeTable(bytInText(i  +   2 )  And   & H3F)
        lngEncodeLen  =  lngEncodeLen  +   4
     Next
    
    i  =  lngInTextLen  -   1   +   1
     If  lngMod  =   1   Then    ' 对剩余字节进行填充
        bytEncode(lngEncodeLen)  =  Base64EncodeTable((bytInText(i)  And   & HFC)  ( 2   ^   2 ))
        bytEncode(lngEncodeLen  +   1 )  =  Base64EncodeTable((bytInText(i)  And   & H3)  *  ( 2   ^   4 ))
        bytEncode(lngEncodeLen  +   2 )  =  Base64EncodeTable( 64 )   ' 填充=
        bytEncode(lngEncodeLen  +   3 )  =  Base64EncodeTable( 64 )   ' 填充=
        lngEncodeLen  =  lngEncodeLen  +   4
     ElseIf  lngMod  =   2   Then
        bytEncode(lngEncodeLen)  =  Base64EncodeTable((bytInText(i)  And   & HFC)  ( 2   ^   2 ))
        bytEncode(lngEncodeLen  +   1 )  =  Base64EncodeTable((bytInText(i)  And   & H3)  *  ( 2   ^   4 )  Or  (bytInText(i  +   1 )  And   & HF0)  ( 2   ^   4 ))
        bytEncode(lngEncodeLen  +   2 )  =  Base64EncodeTable((bytInText(i  +   1 )  And   & HF)  *  ( 2   ^   2 ))
        bytEncode(lngEncodeLen  +   3 )  =  Base64EncodeTable( 64 )   ' 填充=
        lngEncodeLen  =  lngEncodeLen  +   4
     End   If

    Base64_Encode  =  bytEncode()
End Function

' Base64解码函数
Public   Function  Base64_Decode(bytInText()  As   Byte )  As   Byte ()
     Dim  Base64DecodeTable( 1   To   122 )  As   Byte
     Dim  lngInTextLen  As   Long , i  As   Long
     Dim  bytDecode()  As   Byte , lngDecodeLen  As   Long
    
    Base64_Decode  =   Chr ( 0 )   ' 初始化函数返回值
    
     If   LBound (bytInText)  <>   0   Then   Exit Function    ' bytInText数组下标不从零开始则出错返回
    
    lngInTextLen  =   UBound (bytInText)  -   LBound (bytInText)  +   1    ' 计算bytInText数组长度
     If  lngInTextLen  Mod   4   <>   0   Then   Exit Function    ' 输入编码不是4的倍数则出错返回
    
     For  i  =   1   To   122    ' 初始化Base64解码表
         Select   Case  i
         Case   43    ' +
            Base64DecodeTable(i)  =   62
         Case   47    ' /
            Base64DecodeTable(i)  =   63
         Case   48   To   57    ' 0 - 9
            Base64DecodeTable(i)  =   52   +  (i  -   48 )
         Case   65   To   90    ' A - Z
            Base64DecodeTable(i)  =   0   +  (i  -   65 )
         Case   97   To   122    ' a - z
            Base64DecodeTable(i)  =   26   +  (i  -   97 )
         Case   Else
            Base64DecodeTable(i)  =   255
         End   Select
     Next
    lngDecodeLen  =  lngInTextLen  /   4   *   3    ' 求解码后的最大长度
     ReDim  bytDecode( 0   To  lngDecodeLen  -   1 )   ' 重新定义解码缓冲区
     ' MsgBox "解码后的最大长度为：" & lngDecodeLen
    
    lngDecodeLen  =   0    ' 初始化解码长度
    
     For  i  =   0   To  lngInTextLen  -   1   Step   4
        bytDecode(lngDecodeLen)  =  (Base64DecodeTable(bytInText(i))  *  ( 2   ^   2 ))  Or  ((Base64DecodeTable(bytInText(i  +   1 ))  And   & H30)  ( 2   ^   4 ))
        bytDecode(lngDecodeLen  +   1 )  =  ((Base64DecodeTable(bytInText(i  +   1 ))  And   & HF)  *  ( 2   ^   4 ))  Or  ((Base64DecodeTable(bytInText(i  +   2 ))  And   & H3C)  ( 2   ^   2 ))
        bytDecode(lngDecodeLen  +   2 )  =  ((Base64DecodeTable(bytInText(i  +   2 ))  And   & H3)  *  ( 2   ^   6 ))  Or  Base64DecodeTable(bytInText(i  +   3 ))
        lngDecodeLen  =  lngDecodeLen  +   3
     Next
    
     If  bytInText(lngInTextLen  -   1 )  =   & H3D  Then    ' 判断最后两个字节的情况,求解码后的实际长度
         If  bytInText(lngInTextLen  -   2 )  =   & H3D  Then
            lngDecodeLen  =  lngDecodeLen  -   2    ' 最后两个字节为"="
         Else
            lngDecodeLen  =  lngDecodeLen  -   1    ' 最后一个字节为"="
         End   If
        bytDecode(lngDecodeLen)  =   0    ' 在实际长度的后一个字节放个结束符
     End   If
     ' MsgBox "解码后的实际长度为：" & lngDecodeLen
    
    Base64_Decode  =  bytDecode()
End Function

frmLogin.frm窗体:

Option   Explicit

Private   Sub  cmdAdd_Click()   ' 添加按钮
    frmSet.Show  1    ' 模态显示设置对话框
     Call  QQ_DB_UpdataUserList(lvListView)
End Sub

Private   Sub  cmdDel_Click()   ' 删除按钮
     Dim  i  As   Integer , blnSelect  As   Boolean
    
     For  i  =   1   To  lvListView.ListItems.Count
         If  lvListView.ListItems(i).Checked  =   True   Then
            blnSelect  =   True
             If   MsgBox ( " 你确定要删除QQ号码为: "   &  lvListView.ListItems(i).Text  &   " 的记录吗？ " , vbInformation  +  vbOKCancel,  " QQ自动登录器 " )  =  vbOK  Then
                 Call  QQ_DB_Del(lvListView.ListItems(i).Text)
             End   If
         End   If
     Next
    
     Call  QQ_DB_UpdataUserList(lvListView)
     If  blnSelect  =   False   Then
         MsgBox   " 请先选择一个QQ号码！ " , vbInformation  +  vbOKOnly,  " QQ自动登录器 "
     End   If
End Sub

Private   Sub  cmdExit_Click()   ' 退出按钮
     End
End Sub

Private   Sub  cmdLogin_Click()   ' 登录按钮
     Dim  i  As   Integer , strNum  As   String , intLoginMode  As   Integer , blnSelect  As   Boolean
    
     If  chkLoginMode.Value  =   1   Then    ' 选中隐身登录复选框
        intLoginMode  =   40
     Else
        intLoginMode  =   41
     End   If
    
     For  i  =   1   To  lvListView.ListItems.Count
         If  lvListView.ListItems(i).Checked  =   True   Then
            blnSelect  =   True
            
            strNum  =  lvListView.ListItems(i).Text
             Call  QQ_AutoLogin(strNum, intLoginMode)  ' 自动登录QQ
         End   If
     Next
    
     If  blnSelect  =   False   Then
         MsgBox   " 请先选择一个QQ号码！ " , vbInformation  +  vbOKOnly,  " QQ自动登录器 "
     End   If
End Sub

Private   Sub  cmdModify_Click()   ' 修改按钮
     Dim  i  As   Integer , blnSelect  As   Boolean
    
     For  i  =   1   To  lvListView.ListItems.Count
         If  lvListView.ListItems(i).Checked  =   True   Then
            blnSelect  =   True
            frmSet.g_strNum  =  lvListView.ListItems(i).Text
            frmSet.Show  1
         End   If
     Next
    
     If  blnSelect  =   False   Then
         MsgBox   " 请先选择一个QQ号码！ " , vbInformation  +  vbOKOnly,  " QQ自动登录器 "
     End   If
End Sub

Private   Sub  Form_Load()
     If  QQ_DB_Connect  =   False   Then   ' 连接数据库
         End
     End   If
    lvListView.SmallIcons  =  ilImageList
     Call  QQ_DB_UpdataUserList(lvListView)
End Sub

Private   Sub  lvListView_ItemClick( ByVal  Item  As  MSComctlLib.ListItem)
    lvListView.SelectedItem.Checked  =   Not  lvListView.SelectedItem.Checked
End Sub

Private   Sub  Form_Unload(Cancel  As   Integer )
     Call  QQ_DB_Deconnetion   ' 断开与数据库的连接
End Sub

frmSet.frm窗体：

Option   Explicit
Public  g_strNum  As   String    ' 保存主窗口传递过来的QQ号码变量

Private   Sub  cmdCancel_Click()   ' 取消按钮
    Unload frmSet
End Sub

Private   Sub  cmdOK_Click()   ' 确定按钮
     Dim  strNum  As   String , strPwd  As   String , lngRet  As   Long
    
     If   Trim (txtNumber.Text)  =   ""   Or   Trim (txtPassword.Text)  =   ""   Or   Trim (txtPassword2.Text)  =   ""   Then
         MsgBox   " 请输入完整的信息！ " , vbInformation  Or  vbOKOnly,  " QQ自动登录器 "
        txtNumber.SetFocus
         Exit Sub
     End   If
    
     If   Trim (txtPassword.Text)  <>   Trim (txtPassword2.Text)  Then
         MsgBox   " 两次输入的密码不一致，请重新输入！ " , vbInformation  Or  vbOKOnly,  " QQ自动登录器 "
        txtPassword.Text  =   ""
        txtPassword2.Text  =   ""
        txtPassword.SetFocus
         Exit Sub
     End   If
    
    strNum  =   Trim (txtNumber.Text)
    strPwd  =   Trim (txtPassword.Text)
    
     If  g_strNum  <>   ""   Then    ' 修改密码信息
         Call  QQ_DB_Edit(strNum, strPwd)
         MsgBox   " 修改成功！ " , vbInformation  Or  vbOKOnly,  " QQ自动登录器 "
        Unload frmSet
     Else   ' 添加密码信息
         If  QQ_DB_Find(strNum)  Then
             If   MsgBox ( " 您所输入的QQ号码信息已存在数据库中，是否改变密码信息？ " , vbInformation  Or  vbYesNo,  " QQ自动登录器 " )  =  vbYes  Then
                 Call  QQ_DB_Edit(strNum, strPwd)
                 MsgBox   " 修改成功！ " , vbInformation  Or  vbOKOnly,  " QQ自动登录器 "
                Unload frmSet
             Else
                 Exit Sub
             End   If
         Else
             Call  QQ_DB_Add(strNum, strPwd)
             MsgBox   " 记录成功！ " , vbInformation  Or  vbOKOnly,  " QQ自动登录器 "
            Unload frmSet
         End   If
     End   If
End Sub

Private   Sub  Form_Load()
     If  g_strNum  <>   ""   Then
        txtNumber.Text  =  g_strNum
        txtNumber.Enabled  =   False
     End   If
End Sub

Private   Sub  Form_Unload(Cancel  As   Integer )
    g_strNum  =   ""
End Sub

Private   Sub  txtNumber_KeyPress(KeyAscii  As   Integer )
     If  KeyAscii  >=   Asc ( 0 )  And  KeyAscii  <=   Asc ( 9 )  Or  KeyAscii  =   8   Or  KeyAscii  =   13   Then
        
     Else
        KeyAscii  =   0
     End   If
End Sub

     该程序用ACCESS保存QQ的密码信息，可以实现批量登录。当你有多个QQ号码需要登录的时候就不用一个个去按QQ输密码了。程序还有一个需要改进的地方，就是保存密码的时候保存的是明文，虽然数据库加了密码，但现在ACCESS数据库好像不是很安全，网上经常看到有破解ACCESS数据库密码之类的文章。所以建议大家在保存密码的时候最好再加个自己的加密的方法。(直接保存密码的MD5也是不安全的喔，别人知道了MD5一样是可以登录你QQ的)