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

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

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

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

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