上一次写过一篇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
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
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
' 除以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
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
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
1327
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
