无聊中，发个自己测试用的登陆系统代码供大家参考学习
建立起一个标准模块，一个窗体form1，窗体简历两个text，两个command，如果需要密码MD5加密的可以再加个类模块，代码下面也附上了。窗体form1的代码：代码很简洁吧
Private Sub Form_Load()'注意下面的注释
Me.Show '一定要放在下面一条代码前面，因为SetFocus属性在窗体显示出来之前是无效的，会出错
Text1.SetFocus '放在Show下面
End Sub
Private Sub command1_Click()'确定登陆
If 登陆(Text1.Text, text2.Text) = 1 Then’在模块中封装了 登陆(TEXTNAME, TEXTPASSWORD)，登陆成功就返回数值1
需要打开的窗体.Show
Unload Me
End If
End Sub
Private Sub command2_Click()’取消登陆退出
End
End Sub
下面是模块内容：
Option Explicit
Dim dlcs As Integer '尝试登陆次数变量，用来记录登陆失败次数
Dim cn As ADODB.Connection
Dim rs As ADODB.Recordset
Dim sql As String
Public Function 登陆(ByVal TEXTNAME As String, ByVal TEXTPASSWORD As String) As Long '登陆模块，返回一个数值1
’ByVal TEXTNAME As String中的ByVal表示获取的是登陆窗体text1中输入的原始字符，ByVal TEXTPASSWORD As String的意思一样的，着的获取的是text2中的也就是密码
Set cn = New ADODB.Connection
Set rs = New ADODB.Recordset
If TEXTNAME = "" Then '如果传递过来的text1中的字符串为空就提示
MsgBox "用户名不能为空！", 48, "系统"
Exit Function’退出函数过程
ElseIf TEXTPASSWORD = "" Then '和上面的一样，如果传递过来的text2中的字符串为空也就是没有填写密码就提示
MsgBox "请填写密码！", 48, "系统"
Exit Function
End If
cn.Open "provider=microsoft.ace.oledb.12.0;Data Source=" & App.Path & "\数据库名.accdb;Jet OLEDB:Database Password=数据库密码;"
sql = "select * from 用户表 where 用户名 = '" & Trim(TEXTNAME) & "' "
If rs.State = 1 Then rs.Close '如果数据库没有关闭就先关闭再打开
rs.Open sql, cn, 3, 3 '开始查询数据库
If rs.EOF And rs.BOF Then ’如果没有查询到符合的用户名就提示
MsgBox "用户名或密码错误!", 48, "系统" '为了减少猜测几率，不提示是用户名错还是密码错误，减少猜测破解
GoTo ExitSub '错误了就跳转到标识处
End If
'---------------------'下面的是我的登陆模块里增加了一个MD5密码加密模块，是类模块，需要的可以也加一个，不需要的可以把俩行“----”中间的去掉
’下面有类模块的代码，我是网上COPY过来的，能用，不过为了尽量保密，在加密的密码字符串后面最好再加点别的字符串一起加密。
'加密
’要用加密过程的话你创建用户名的时候也需要对密码加密，要不然你是无法登陆的，会提示密码或用户名错误
'因为加密后密码核对的是加密后的一个字符串
’加密后的好处就是，如果数据库被破解了，你的密码也没人知道，因为在数据库里记录的密码是加密过后的一个无序的字符串。
Dim md5
Dim md As String
Set md5 = New Class1
md = TEXTPASSWORD & "另外增加的字符串"
md = md5.Md5_String_Calc(md)
'---------------------上面是加密
If rs.Fields("密码") <> md Then '如果不用加密模块这里可以这样写 If rs.Fields("密码") <> TEXTPASSWORD Then
MsgBox "用户名或密码错误!", 48, "系统"
GoTo ExitSub '错误了就跳转到标识处
Else
If cn.State = adStateOpen Then cn.Close
If rs.State = adStateOpen Then rs.Close
登陆 = 1 '关键就是这个，返回一个验证通过可以登陆的标志，登陆 = 什么随你，不过在FORM1中你也要同时改
Exit Function '这句不能少，少了这句，如果你错了3次第四次登陆对了就会弹出出错提示并退出程序的
End If
ExitSub: ’这个就是错误标识处
dlcs = dlcs + 1 '登陆次数+1 '出错了就记录次数+1
If dlcs = 4 Then '如果连续4次错误，那么就执行下面的，提示并退出程序，如果想出错3次就退出就把前面的=4改成=3
MsgBox "请与管理员联系!", 48, "系统"
If cn.State = adStateOpen Then cn.Close
If rs.State = adStateOpen Then rs.Close
End
End If
If cn.State = adStateOpen Then cn.Close
If rs.State = adStateOpen Then rs.Close
End Function
类模块代码：密码加密用的，下面的我就不注释了，复制到类模块就可以了
Option Explicit
Private Const OFFSET_4 = 4294967296#
Private Const MAXINT_4 = 2147483647
Private State(4) As Long
Private ByteCounter As Long
Private ByteBuffer(63) As Byte
Private Const S11 = 7
Private Const S12 = 12
Private Const S13 = 17
Private Const S14 = 22
Private Const S21 = 5
Private Const S22 = 9
Private Const S23 = 14
Private Const S24 = 20
Private Const S31 = 4
Private Const S32 = 11
Private Const S33 = 16
Private Const S34 = 23
Private Const S41 = 6
Private Const S42 = 10
Private Const S43 = 15
Private Const S44 = 21
Property Get RegisterA() As String
RegisterA = State(1)
End Property
Property Get RegisterB() As String
RegisterB = State(2)
End Property
Property Get RegisterC() As String
RegisterC = State(3)
End Property
Property Get RegisterD() As String
RegisterD = State(4)
End Property
Public Function Md5_String_Calc(SourceString As String) As String
MD5Init
MD5Update LenB(StrConv(SourceString, vbFromUnicode)), StringToArray(SourceString)
MD5Final
Md5_String_Calc = GetValues
End Function
Public Function Md5_File_Calc(InFile As String) As String
On Error GoTo errorhandler
GoSub begin
errorhandler:
Dim DigestFileToHexStr As String
DigestFileToHexStr = ""
Exit Function
begin:
Dim FileO As Integer
FileO = FreeFile
Call FileLen(InFile)
Open InFile For Binary Access Read As #FileO
MD5Init
Do While Not EOF(FileO)
Get #FileO, , ByteBuffer
If Loc(FileO) < LOF(FileO) Then
ByteCounter = ByteCounter + 64
MD5Transform ByteBuffer
End If
Loop
ByteCounter = ByteCounter + (LOF(FileO) Mod 64)
Close #FileO
MD5Final
Md5_File_Calc = GetValues
End Function
Private Function StringToArray(InString As String) As Byte()
Dim i As Integer, bytBuffer() As Byte
ReDim bytBuffer(LenB(StrConv(InString, vbFromUnicode)))
bytBuffer = StrConv(InString, vbFromUnicode)
StringToArray = bytBuffer
End Function
Public Function GetValues() As String
GetValues = LongToString(State(1)) & LongToString(State(2)) & LongToString(State(3)) & LongToString(State(4))
End Function
Private Function LongToString(Num As Long) As String
Dim A As Byte, B As Byte, C As Byte, D As Byte
A = Num And &HFF&
If A < 16 Then LongToString = "0" & Hex(A) Else LongToString = Hex(A)
B = (Num And &HFF00&) / 256
If B < 16 Then LongToString = LongToString & "0" & Hex(B) Else LongToString = LongToString & Hex(B)
C = (Num And &HFF0000) / 65536
If C < 16 Then LongToString = LongToString & "0" & Hex(C) Else LongToString = LongToString & Hex(C)
If Num < 0 Then D = ((Num And &H7F000000) / 16777216) Or &H80& Else D = (Num And &HFF000000) / 16777216
If D < 16 Then LongToString = LongToString & "0" & Hex(D) Else LongToString = LongToString & Hex(D)
End Function
Public Sub MD5Init()
ByteCounter = 0
State(1) = UnsignedToLong(1732584193#)
State(2) = UnsignedToLong(4023233417#)
State(3) = UnsignedToLong(2562383102#)
State(4) = UnsignedToLong(271733878#)
End Sub
Public Sub MD5Final()
Dim dblBits As Double, padding(72) As Byte, lngBytesBuffered As Long
padding(0) = &H80
dblBits = ByteCounter * 8
lngBytesBuffered = ByteCounter Mod 64
If lngBytesBuffered <= 56 Then MD5Update 56 - lngBytesBuffered, padding Else MD5Update 120 - ByteCounter, padding
padding(0) = UnsignedToLong(dblBits) And &HFF&
padding(1) = UnsignedToLong(dblBits) / 256 And &HFF&
padding(2) = UnsignedToLong(dblBits) / 65536 And &HFF&
padding(3) = UnsignedToLong(dblBits) / 16777216 And &HFF&
padding(4) = 0
padding(5) = 0
padding(6) = 0
padding(7) = 0
MD5Update 8, padding
End Sub
Public Sub MD5Update(InputLen As Long, InputBuffer() As Byte)
Dim II As Integer, i As Integer, J As Integer, k As Integer, lngBufferedBytes As Long, lngBufferRemaining As Long, lngRem As Long
lngBufferedBytes = ByteCounter Mod 64
lngBufferRemaining = 64 - lngBufferedBytes
ByteCounter = ByteCounter + InputLen
If InputLen >= lngBufferRemaining Then
For II = 0 To lngBufferRemaining - 1
ByteBuffer(lngBufferedBytes + II) = InputBuffer(II)
Next II
MD5Transform ByteBuffer
lngRem = (InputLen) Mod 64
For i = lngBufferRemaining To InputLen - II - lngRem Step 64
For J = 0 To 63
ByteBuffer(J) = InputBuffer(i + J)
Next J
MD5Transform ByteBuffer
Next i
lngBufferedBytes = 0
Else
i = 0
End If
For k = 0 To InputLen - i - 1
ByteBuffer(lngBufferedBytes + k) = InputBuffer(i + k)
Next k
End Sub
Private Sub MD5Transform(Buffer() As Byte)
Dim X(16) As Long, A As Long, B As Long, C As Long, D As Long
A = State(1)
B = State(2)
C = State(3)
D = State(4)
Decode 64, X, Buffer
FF A, B, C, D, X(0), S11, -680876936
FF D, A, B, C, X(1), S12, -389564586
FF C, D, A, B, X(2), S13, 606105819
FF B, C, D, A, X(3), S14, -1044525330
FF A, B, C, D, X(4), S11, -176418897
FF D, A, B, C, X(5), S12, 1200080426
FF C, D, A, B, X(6), S13, -1473231341
FF B, C, D, A, X(7), S14, -45705983
FF A, B, C, D, X(8), S11, 1770035416
FF D, A, B, C, X(9), S12, -1958414417
FF C, D, A, B, X(10), S13, -42063
FF B, C, D, A, X(11), S14, -1990404162
FF A, B, C, D, X(12), S11, 1804603682
FF D, A, B, C, X(13), S12, -40341101
FF C, D, A, B, X(14), S13, -1502002290
FF B, C, D, A, X(15), S14, 1236535329
GG A, B, C, D, X(1), S21, -165796510
GG D, A, B, C, X(6), S22, -1069501632
GG C, D, A, B, X(11), S23, 643717713
GG B, C, D, A, X(0), S24, -373897302
GG A, B, C, D, X(5), S21, -701558691
GG D, A, B, C, X(10), S22, 38016083
GG C, D, A, B, X(15), S23, -660478335
GG B, C, D, A, X(4), S24, -405537848
GG A, B, C, D, X(9), S21, 568446438
GG D, A, B, C, X(14), S22, -1019803690
GG C, D, A, B, X(3), S23, -187363961
GG B, C, D, A, X(8), S24, 1163531501
GG A, B, C, D, X(13), S21, -1444681467
GG D, A, B, C, X(2), S22, -51403784
GG C, D, A, B, X(7), S23, 1735328473
GG B, C, D, A, X(12), S24, -1926607734
HH A, B, C, D, X(5), S31, -378558
HH D, A, B, C, X(8), S32, -2022574463
HH C, D, A, B, X(11), S33, 1839030562
HH B, C, D, A, X(14), S34, -35309556
HH A, B, C, D, X(1), S31, -1530992060
HH D, A, B, C, X(4), S32, 1272893353
HH C, D, A, B, X(7), S33, -155497632
HH B, C, D, A, X(10), S34, -1094730640
HH A, B, C, D, X(13), S31, 681279174
HH D, A, B, C, X(0), S32, -358537222
HH C, D, A, B, X(3), S33, -722521979
HH B, C, D, A, X(6), S34, 76029189
HH A, B, C, D, X(9), S31, -640364487
HH D, A, B, C, X(12), S32, -421815835
HH C, D, A, B, X(15), S33, 530742520
HH B, C, D, A, X(2), S34, -995338651
II A, B, C, D, X(0), S41, -198630844
II D, A, B, C, X(7), S42, 1126891415
II C, D, A, B, X(14), S43, -1416354905
II B, C, D, A, X(5), S44, -57434055
II A, B, C, D, X(12), S41, 1700485571
II D, A, B, C, X(3), S42, -1894986606
II C, D, A, B, X(10), S43, -1051523
II B, C, D, A, X(1), S44, -2054922799
II A, B, C, D, X(8), S41, 1873313359
II D, A, B, C, X(15), S42, -30611744
II C, D, A, B, X(6), S43, -1560198380
II B, C, D, A, X(13), S44, 1309151649
II A, B, C, D, X(4), S41, -145523070
II D, A, B, C, X(11), S42, -1120210379
II C, D, A, B, X(2), S43, 718787259
II B, C, D, A, X(9), S44, -343485551
State(1) = LongOverflowAdd(State(1), A)
State(2) = LongOverflowAdd(State(2), B)
State(3) = LongOverflowAdd(State(3), C)
State(4) = LongOverflowAdd(State(4), D)
End Sub
Private Sub Decode(Length As Integer, OutputBuffer() As Long, InputBuffer() As Byte)
Dim intDblIndex As Integer, intByteIndex As Integer, dblSum As Double
For intByteIndex = 0 To Length - 1 Step 4
dblSum = InputBuffer(intByteIndex) + InputBuffer(intByteIndex + 1) * 256# + InputBuffer(intByteIndex + 2) * 65536# + InputBuffer(intByteIndex + 3) * 16777216#
OutputBuffer(intDblIndex) = UnsignedToLong(dblSum)
intDblIndex = intDblIndex + 1
Next intByteIndex
End Sub
Private Function FF(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And C) Or (Not (B) And D), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function GG(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, (B And D) Or (C And Not (D)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function HH(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, B Xor C Xor D, X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Private Function II(A As Long, B As Long, C As Long, D As Long, X As Long, S As Long, ac As Long) As Long
A = LongOverflowAdd4(A, C Xor (B Or Not (D)), X, ac)
A = LongLeftRotate(A, S)
A = LongOverflowAdd(A, B)
End Function
Function LongLeftRotate(Value As Long, Bits As Long) As Long
Dim lngSign As Long, lngI As Long
Bits = Bits Mod 32
If Bits = 0 Then LongLeftRotate = Value: Exit Function
For lngI = 1 To Bits
lngSign = Value And &HC0000000
Value = (Value And &H3FFFFFFF) * 2
Value = Value Or ((lngSign < 0) And 1) Or (CBool(lngSign And &H40000000) And &H80000000)
Next
LongLeftRotate = Value
End Function
Private Function LongOverflowAdd(Val1 As Long, Val2 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&)
lngOverflow = lngLowWord / 65536
lngHighWord = (((Val1 And &HFFFF0000) / 65536) + ((Val2 And &HFFFF0000) / 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function LongOverflowAdd4(Val1 As Long, Val2 As Long, val3 As Long, val4 As Long) As Long
Dim lngHighWord As Long, lngLowWord As Long, lngOverflow As Long
lngLowWord = (Val1 And &HFFFF&) + (Val2 And &HFFFF&) + (val3 And &HFFFF&) + (val4 And &HFFFF&)
lngOverflow = lngLowWord / 65536
lngHighWord = (((Val1 And &HFFFF0000) / 65536) + ((Val2 And &HFFFF0000) / 65536) + ((val3 And &HFFFF0000) / 65536) + ((val4 And &HFFFF0000) / 65536) + lngOverflow) And &HFFFF&
LongOverflowAdd4 = UnsignedToLong((lngHighWord * 65536#) + (lngLowWord And &HFFFF&))
End Function
Private Function UnsignedToLong(Value As Double) As Long
If Value < 0 Or Value >= OFFSET_4 Then Error 6
If Value <= MAXINT_4 Then UnsignedToLong = Value Else UnsignedToLong = Value - OFFSET_4
End Function
Private Function LongToUnsigned(Value As Long) As Double
If Value < 0 Then LongToUnsigned = Value + OFFSET_4 Else LongToUnsigned = Value
End Function
[ 本帖最后由 wxflw 于 2013-11-14 20:38 编辑 ]
