上一次写过一篇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模块：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
m_Base64模块：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
frmLogin.frm窗体:'除以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
frmSet.frm窗体：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
该程序用ACCESS保存QQ的密码信息，可以实现批量登录。当你有多个QQ号码需要登录的时候就不用一个个去按QQ输密码了。程序还有一个需要改进的地方，就是保存密码的时候保存的是明文，虽然数据库加了密码，但现在ACCESS数据库好像不是很安全，网上经常看到有破解ACCESS数据库密码之类的文章。所以建议大家在保存密码的时候最好再加个自己的加密的方法。(直接保存密码的MD5也是不安全的喔，别人知道了MD5一样是可以登录你QQ的)
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