登陆.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  '缺省游标
      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字符，另外不要将其设为中文或其他种类文字，只允许设为字符或数字组成的四位以上的密码1111为密码亦不允许，切记，否则会无法进入使用/正常使用该用户）：")
    If jj = vbNullString Then MsgBox "密码设置出错，不能没有密码！请大侠再来过……": 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 "发现同名！操作取消。请大侠重新来过！": 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 "设置密码成功！你使用的密码是：" & 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("删除当前用户会连带其所关联的日记记录全部删除！你确定继续吗？", vbYesNo) = vbNo Then Exit Sub
If txtPassword.Text = vbNullString Then MsgBox "请在输入密码处输正确的该用户使用密码！": Exit Sub
If Len(txtPassword.Text) < 4 Then MsgBox "密码不对！如果非要删除不可的话，请联系本作者（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 "已经删除成功！"

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
If txtPassword.Text <> Text1.Text Then MsgBox "输入的密码有误！请重新输入！": txtPassword.SetFocus: SendKeys "{Home}+{End}": Exit Sub
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
'加密调用的过程。
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
'取消读取数据库出错指示。
'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()
'加密调用的过程。
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