?? 登陸.frm
字號:
VERSION 5.00
Begin VB.Form frmLogin
BorderStyle = 3 'Fixed Dialog
Caption = "日記程序登錄"
ClientHeight = 1635
ClientLeft = 2835
ClientTop = 3480
ClientWidth = 6045
Icon = "登陸.frx":0000
LinkTopic = "Form6"
LockControls = -1 'True
MaxButton = 0 'False
MinButton = 0 'False
ScaleHeight = 966.012
ScaleMode = 0 'User
ScaleWidth = 5675.928
ShowInTaskbar = 0 'False
StartUpPosition = 2 '屏幕中心
Begin VB.CommandButton Command9
Caption = ">>"
Height = 495
Left = 2880
TabIndex = 16
Top = 1080
Width = 615
End
Begin VB.CommandButton Command8
Caption = ">"
Height = 495
Left = 2280
TabIndex = 15
Top = 1080
Width = 615
End
Begin VB.CommandButton Command7
Caption = "修改密碼"
Height = 495
Left = 1320
TabIndex = 14
Top = 1080
Width = 975
End
Begin VB.CommandButton Command6
Caption = "<"
Height = 495
Left = 720
TabIndex = 13
Top = 1080
Width = 615
End
Begin VB.CommandButton Command5
Caption = "<<"
Height = 495
Left = 120
TabIndex = 12
Top = 1080
Width = 615
End
Begin VB.CommandButton Command4
Caption = "取消"
Height = 375
Left = 3720
TabIndex = 11
Top = 1200
Width = 1095
End
Begin VB.CommandButton Command3
Caption = "刪除"
Height = 375
Left = 3720
TabIndex = 10
Top = 840
Width = 1095
End
Begin VB.CommandButton Command2
Caption = "添加"
Height = 375
Left = 3720
TabIndex = 9
Top = 480
Width = 1095
End
Begin VB.CommandButton Command1
Caption = "確定"
Default = -1 'True
Height = 375
Left = 3720
TabIndex = 8
Top = 120
Width = 1095
End
Begin VB.TextBox Text2
DataField = "pndcX2"
DataSource = "Data1"
Height = 375
Left = 120
TabIndex = 7
Text = "Text2"
Top = 960
Visible = 0 'False
Width = 1215
End
Begin VB.ListBox List1
ForeColor = &H00FF00FF&
Height = 1500
Left = 4800
TabIndex = 3
Top = 120
Width = 1215
End
Begin VB.TextBox Text4
DataField = "etynX"
DataSource = "Data1"
ForeColor = &H00C0C000&
Height = 375
Left = 1290
TabIndex = 1
Text = "Text4"
Top = 120
Width = 2175
End
Begin VB.TextBox Text3
DataField = "pathX"
DataSource = "Data1"
Height = 375
Left = 4680
TabIndex = 6
Text = "Text3"
Top = 1080
Visible = 0 'False
Width = 1215
End
Begin VB.TextBox Text1
DataField = "pndcX"
DataSource = "Data1"
Height = 390
Left = 4680
TabIndex = 5
Text = "Text1"
Top = 360
Visible = 0 'False
Width = 1215
End
Begin VB.Data Data1
Caption = "Data1"
Connect = "Access 2000;"
DatabaseName = ""
DefaultCursorType= 0 '缺省游標(biāo)
DefaultType = 2 '使用 ODBC
Exclusive = 0 'False
Height = 405
Left = 2040
Options = 0
ReadOnly = 0 'False
RecordsetType = 1 'Dynaset
RecordSource = "jjyn"
Top = 0
Visible = 0 'False
Width = 1575
End
Begin VB.TextBox txtPassword
Height = 375
IMEMode = 3 'DISABLE
Left = 1290
PasswordChar = "*"
TabIndex = 2
Top = 525
Width = 2175
End
Begin VB.Label lblLabels
Caption = "用戶名稱(&U):"
Height = 270
Index = 0
Left = 105
TabIndex = 0
Top = 150
Width = 1080
End
Begin VB.Label lblLabels
Caption = "密碼(&P):"
Height = 270
Index = 1
Left = 105
TabIndex = 4
Top = 540
Width = 1080
End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Private skinpaths() As String
Dim Firone1 As Boolean
Public LoginSucceeded As Boolean, Pa As String
Dim fsoTest As New FileSystemObject
Dim folder1 As Folder
Private Sub command1_Click()
Password1 = Text2.Text
intForm = 0
getseed (txtPassword.Text)
Mixx
If txtPassword.Text <> Text1.Text Then MsgBox "輸入的密碼有誤！請重新輸入！": txtPassword.SetFocus: SendKeys "{Home}+{End}": Exit Sub
'If Dir$(App.Path & "\data\" & Text4.Text & "\*.gui") = "" Then Pathh = Text3.Text Else Pathh = App.Path & "\data\" & Text4.Text: Text3.Text = App.Path & "\data\" & Text4.Text
Pathh = App.Path & "\data\" & Text4.Text
Text3.Text = App.Path & "\data\" & Text4.Text
Me.Hide
Form6.Show
End Sub
Private Sub command2_Click()
Dim i As Long, j As Long
Dim ii As String, jj As String, l As Long, a As Long, k As String
ii = Trim$(InputBox("新建一用戶，請輸入一個6個漢字或12個英文作為用戶名：", "首次使用請新建一用戶！", "天方夜譚"))
If Len(ii) < 2 Then MsgBox "請輸入兩個字以上的用戶名。": Exit Sub
If ii = vbNullString Then Unload Me
jj = InputBox("請輸入一組新密碼（最多16字符，另外不要將其設(shè)為中文或其他種類文字，只允許設(shè)為字符或數(shù)字組成的四位以上的密碼1111為密碼亦不允許，切記，否則會無法進入使用/正常使用該用戶）：")
If jj = vbNullString Then MsgBox "密碼設(shè)置出錯，不能沒有密碼！請大俠再來過……": Form_Activate: Exit Sub
If Len(jj) < 4 Then MsgBox "密碼不能少于四位，請重新操作！": Form_Activate: Exit Sub
For a = 0 To List1.ListCount
If List1.Text = ii Then MsgBox "發(fā)現(xiàn)同名！操作取消。請大俠重新來過！": Form_Activate: Exit Sub
Next
Data1.EOFAction = 2
Data1.Recordset.AddNew
Text4.Text = ii
txtPassword.Text = jj
intForm = 0
getseed (txtPassword.Text)
temp = ""
Dim intlen
Dim latter
intForm = 1
intTo = Len(txtPassword.Text) - 1
intlen = Len(txtPassword.Text)
Z1 = Mid(txtPassword.Text, 1, intForm - 1)
Z2 = Mid(txtPassword.Text, intForm, intTo - intForm)
z3 = Mid(txtPassword.Text, intTo, intlen)
a = Len(Z2)
For i = 0 To a Step Seedlong
For j = 1 To Seedlong
On Error GoTo c
latter = Asc(Mid(Z2, i + j, 1))
a: latter = Seed(j) Xor Asc(Mid(Z2, i + j, 1))
b: temp = temp & Chr(latter)
Next j
c: Next i
txtPassword.Text = Z1 & temp & z3
Text1.Text = txtPassword.Text
MsgBox "設(shè)置密碼成功！你使用的密碼是：" & jj & "，請記住密碼。"
Text3.Text = Pathh & ii
Text2.Text = Mid(jj, 1, Len(jj) - 1)
MkDirs (Text3.Text)
Data1.UpdateRecord
List1.AddItem (ii)
Data1.EOFAction = 0
List1.ListIndex = 0
Form_Activate
End Sub
Private Sub command3_Click()
Dim sfile As String, l As Long, a As Long
If Text1.Text = "" Then Exit Sub
If MsgBox("刪除當(dāng)前用戶會連帶其所關(guān)聯(lián)的日記記錄全部刪除！你確定繼續(xù)嗎？", vbYesNo) = vbNo Then Exit Sub
If txtPassword.Text = vbNullString Then MsgBox "請在輸入密碼處輸正確的該用戶使用密碼！": Exit Sub
If Len(txtPassword.Text) < 4 Then MsgBox "密碼不對！如果非要刪除不可的話，請聯(lián)系本作者（QQ:282449283）": Exit Sub
Password1 = Text2.Text
intForm = 0
getseed (txtPassword.Text)
Mixx
If txtPassword.Text <> Text1.Text Then MsgBox "輸入的密碼有誤！請重新輸入！": txtPassword.SetFocus: SendKeys "{Home}+{End}": Exit Sub
a = 0
Data1.Recordset.MoveFirst
While a < List1.ListIndex
Data1.Recordset.MoveNext
a = a + 1
Wend
'sfile = Dir$(pathh, vbHidden + vbSystem + vbReadOnly + vbDirectory)
'獲取 Drive 對象。
Set folder1 = fsoTest.GetFolder(Mid(Text3.Text, 1, 2))
'刪除文件夾
'If FileExists(pathh) = False Then Exit Sub
fsoTest.DeleteFolder (Text3.Text)
Data1.Recordset.Delete
MsgBox "已經(jīng)刪除成功！"
sfile = vbNullString
a = 0
Form_Activate
End Sub
Private Sub command4_Click()
Unload Me
End Sub
Private Sub command5_Click()
If Data1.Recordset.BOF = True Then Exit Sub
Data1.Recordset.MoveFirst
List1.ListIndex = 0
End Sub
Private Sub command6_Click()
If List1.ListIndex = 0 Then Exit Sub
Data1.Recordset.MovePrevious
List1.ListIndex = List1.ListIndex - 1
End Sub
Private Sub command7_Click()
Dim aa As String
If txtPassword.Text = vbNullString Then MsgBox "要修改用戶密碼，請先在輸密碼處輸入正確的密碼后再進行修改！": Exit Sub
intForm = 0
getseed (txtPassword.Text)
Mixx
aa = InputBox("請輸入新密碼：", "修改密碼中！")
If aa = vbNullString Then MsgBox "修改密碼不成功！請重新修改密碼。": Exit Sub
If Len(aa) < 4 Then MsgBox "密碼不能低于四位！請大俠重新來過 ^_^": Exit Sub
intForm = 0
intTo = Len(aa) - 3
getseed (aa)
Mixx
'加密調(diào)用的過程。
temp = ""
Dim intlen
Dim latter
intForm = 1
intTo = Len(aa) - 1
intlen = Len(aa)
Z1 = Mid(aa, 1, intForm - 1)
Z2 = Mid(aa, intForm, intTo - intForm)
z3 = Mid(aa, intTo, intlen)
a = Len(Z2)
For i = 0 To a Step Seedlong
For j = 1 To Seedlong
On Error GoTo c
latter = Asc(Mid(Z2, i + j, 1))
a: latter = Seed(j) Xor Asc(Mid(Z2, i + j, 1))
b: temp = temp & Chr(latter)
Next j
c: Next i
txtPassword.Text = Z1 & temp & z3
Text1.Text = txtPassword.Text
Data1.UpdateRecord
Data1.EOFAction = 0
MsgBox "修改成功！"
Form_Activate
End Sub
Private Sub command8_Click()
If List1.ListIndex = List1.ListCount - 1 Then Exit Sub
Data1.Recordset.MoveNext
List1.ListIndex = List1.ListIndex + 1
End Sub
Private Sub command9_Click()
If Data1.Recordset.EOF = True Then Exit Sub
Data1.Recordset.MoveLast
List1.ListIndex = List1.ListCount - 1
End Sub
Private Sub Form_Activate()
Firone1 = True
'新用戶初次使用代碼！
If Data1.Recordset.EOF Then
Firone1 = False
command2_Click
End If
If Firone1 = False And Data1.Recordset.EOF Then End
List1.Clear
Data1.Recordset.MoveFirst
While Not Data1.Recordset.EOF
If Text4.Text <> vbNullString Then List1.AddItem (Text4.Text)
Data1.Recordset.MoveNext
Wend
Data1.Recordset.MoveFirst
txtPassword.SetFocus
End Sub
Private Sub Form_Load()
InitCommonControls
Pathh = App.Path & "\data\"
Dim db As Database
On Error GoTo error1
Set db = OpenDatabase(Pathh)
On Error GoTo 0
: '正常程序開始
:
Exit Sub
error1:
If Err = 3049 Then '資料庫損毀
DBEngine.RepairDatabase Pathh
Resume
Else
'取消讀取數(shù)據(jù)庫出錯指示。
'MsgBox Err & Error(Err)
End If
If FileExists(Pathh & "\da1124.mdb") = False Then MsgBox "欠缺登陸文件！": End
Data1.DatabaseName = App.Path & "\data\da1124.mdb"
XX2 = 7
End Sub
Private Sub Form_Unload(Cancel As Integer)
If FileExists(App.Path & "x.mdb") = True Then Kill App.Path & "x.mdb"
Dim y As String
y = Data1.DatabaseName
If FileExists(y) = True Then
Data1.Recordset.Close
Data1.Database.Close
DBEngine.CompactDatabase y, App.Path & "\x.mdb"
Kill y
FileCopy App.Path & "\x.mdb", y
Kill App.Path & "\x.mdb"
End If
y = vbNullString
End Sub
Private Sub List1_Click()
Dim i As Long
If List1.ListIndex = 0 Then Data1.Recordset.MoveFirst: Exit Sub
If List1.ListIndex = List1.ListCount - 1 Then Data1.Recordset.MoveLast: Exit Sub
Data1.Recordset.MoveFirst
For i = 0 To List1.ListIndex - 1
Data1.Recordset.MoveNext
Next
End Sub
Private Sub Text4_KeyPress(KeyAscii As Integer)
KeyAscii = 0
End Sub
Public Sub Mixx()
'加密調(diào)用的過程。
temp = ""
Dim intlen
Dim latter
intForm = 1
intTo = Len(txtPassword.Text) - 1
intlen = Len(txtPassword.Text)
Z1 = Mid(txtPassword.Text, 1, intForm - 1)
Z2 = Mid(txtPassword.Text, intForm, intTo - intForm)
z3 = Mid(txtPassword.Text, intTo, intlen)
a = Len(Z2)
For i = 0 To a Step Seedlong
For j = 1 To Seedlong
On Error GoTo c
latter = Asc(Mid(Z2, i + j, 1))
a: latter = Seed(j) Xor Asc(Mid(Z2, i + j, 1))
b: temp = temp & Chr(latter)
Next j
c: Next i
txtPassword.Text = Z1 & temp & z3
End Sub
?? 快捷鍵說明
復(fù)制代碼
Ctrl + C
搜索代碼
Ctrl + F
全屏模式
F11
切換主題
Ctrl + Shift + D
顯示快捷鍵
?
增大字號
Ctrl + =
減小字號
Ctrl + -