frmlogin.frm

一个使用MDB的名片管理程序

VERSION 5.00
Begin VB.Form frmLogin 
   Caption         =   "登陆页面"
   ClientHeight    =   4770
   ClientLeft      =   4500
   ClientTop       =   4005
   ClientWidth     =   6285
   LinkTopic       =   "Form1"
   Moveable        =   0   'False
   Picture         =   "frmLogin.frx":0000
   ScaleHeight     =   4770
   ScaleWidth      =   6285
   StartUpPosition =   1  '所有者中心
   Begin VB.TextBox txtUserName 
      Height          =   345
      Left            =   915
      Locked          =   -1  'True
      TabIndex        =   4
      Text            =   "通讯录"
      Top             =   3390
      Width           =   1440
   End
   Begin VB.TextBox txtPassword 
      Height          =   345
      IMEMode         =   3  'DISABLE
      Left            =   915
      PasswordChar    =   "*"
      TabIndex        =   2
      Top             =   3840
      Width           =   1440
   End
   Begin VB.CommandButton cmdCancel 
      Cancel          =   -1  'True
      Caption         =   "取消"
      Height          =   390
      Left            =   1440
      TabIndex        =   1
      Top             =   4320
      Width           =   900
   End
   Begin VB.CommandButton cmdOK 
      Caption         =   "确定"
      Default         =   -1  'True
      Height          =   390
      Left            =   120
      TabIndex        =   0
      Top             =   4320
      Width           =   900
   End
   Begin VB.Label lblLabels 
      BackStyle       =   0  'Transparent
      Caption         =   "用户(&U):"
      Height          =   270
      Index           =   0
      Left            =   120
      TabIndex        =   5
      Top             =   3420
      Width           =   840
   End
   Begin VB.Label lblLabels 
      BackStyle       =   0  'Transparent
      Caption         =   "密码(&P):"
      Height          =   270
      Index           =   1
      Left            =   120
      TabIndex        =   3
      Top             =   3870
      Width           =   1020
   End
End
Attribute VB_Name = "frmLogin"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Public OK As Boolean
Private Sub cmdCancel_Click()
    OK = False
    Me.Hide
End Sub

Private Sub cmdOK_Click()
Dim Number As String * 20
    Filenum = FreeFile
Open "c:\rbcic\ktxbps.dat" For Random As #Filenum Len = 20
        Get #Filenum, 1, Number
        Close #Filenum
'解密
    Dim plain_text As String
    Decipher txtPassword.Text, Trim(Number), plain_text
    If txtPassword.Text = plain_text Then
    OK = True
    Me.Hide
    Else
    MsgBox "输入密码错误！", vbExclamation, "严重错误":
    txtPassword.SetFocus
        txtPassword.SelStart = 0
        txtPassword.SelLength = Len(txtPassword.Text)
    End If
End Sub

Private Function NumericPassword(ByVal password As String) As Long
    Dim value As Long
    Dim ch As Long
    Dim shift1 As Long
    Dim shift2 As Long
    Dim i As Integer
    Dim str_len As Integer
        str_len = Len(password)
        For i = 1 To str_len
            
            ch = Asc(Mid$(password, i, 1))
            value = value Xor (ch * 2 ^ shift1)
            value = value Xor (ch * 2 ^ shift2)
    
            shift1 = (shift1 + 7) Mod 19
            shift2 = (shift2 + 13) Mod 23
        Next i
        NumericPassword = value
End Function

Private Sub Decipher(ByVal password As String, ByVal from_text As String, to_text As String)
    Const MIN_ASC = 32  ' Space.
    Const MAX_ASC = 126 ' ~.
    Const NUM_ASC = MAX_ASC - MIN_ASC + 1
    
    Dim offset As Long
    Dim str_len As Integer
    Dim i As Integer
    Dim ch As Integer
    
        offset = NumericPassword(password)
        Rnd -1
        Randomize offset
    
        str_len = Len(from_text)
        For i = 1 To str_len
            ch = Asc(Mid$(from_text, i, 1))
            If ch >= MIN_ASC And ch <= MAX_ASC Then
                ch = ch - MIN_ASC
                offset = Int((NUM_ASC + 1) * Rnd)
                ch = ((ch - offset) Mod NUM_ASC)
                If ch < 0 Then ch = ch + NUM_ASC
                ch = ch + MIN_ASC
                to_text = to_text & Chr$(ch)
            End If
        Next i
End Sub

Private Sub Form_Load()
'If Format(Date, "yyyy-mm-dd") > "29991231" Then
'MsgBox " "
'End If
End Sub