frmpass.frm

常驻人口户籍管理系统DELPHI开的的,还不错.学习用

VERSION 5.00
Begin VB.Form Frmpass 
   Caption         =   "更改密码"
   ClientHeight    =   2010
   ClientLeft      =   5355
   ClientTop       =   4980
   ClientWidth     =   4095
   Icon            =   "Frmpass.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   ScaleHeight     =   2010
   ScaleWidth      =   4095
   Begin VB.TextBox Text1 
      Height          =   375
      IMEMode         =   3  'DISABLE
      Left            =   1200
      PasswordChar    =   "*"
      TabIndex        =   3
      Top             =   240
      Width           =   2415
   End
   Begin VB.TextBox Text2 
      Height          =   375
      IMEMode         =   3  'DISABLE
      Left            =   1200
      PasswordChar    =   "*"
      TabIndex        =   2
      Top             =   960
      Width           =   2415
   End
   Begin VB.CommandButton Command1 
      Caption         =   "确 定(&Y)"
      Height          =   375
      Left            =   120
      TabIndex        =   1
      Top             =   1440
      Width           =   1455
   End
   Begin VB.CommandButton Command2 
      Caption         =   "取 消(&C)"
      Height          =   375
      Left            =   2160
      TabIndex        =   0
      Top             =   1440
      Width           =   1455
   End
   Begin VB.Label Label1 
      Caption         =   "输入新密码"
      Height          =   255
      Left            =   120
      TabIndex        =   5
      Top             =   240
      Width           =   1095
   End
   Begin VB.Label Label2 
      Caption         =   "确认新密码"
      Height          =   255
      Left            =   120
      TabIndex        =   4
      Top             =   960
      Width           =   1095
   End
End
Attribute VB_Name = "Frmpass"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Command1_Click()
Dim rpt As Integer
rpt = MsgBox("确定要更改密码吗？", vbYesNo + vbExclamation + vbDefaultButton2, "密码警告")
If rpt = vbYes Then
If Text1.Text = Text2.Text Then
    Filenum = FreeFile
Dim Number As String * 20
Open "c:\rbcic\ktxbps.dat" For Random As #Filenum Len = 20
    Dim cipher_text As String
    Cipher Text2.Text, Text2.Text, cipher_text
    Number = cipher_text
        Put #Filenum, 1, Number
        Close #Filenum
Unload Me
Else
MsgBox ("请重新输入密码 ！！！"): End If
Else
Exit Sub: End If

End Sub

Private Sub Cipher(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)
                ch = ch + MIN_ASC
                to_text = to_text & Chr$(ch)
            End If
        Next i
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 Command2_Click()
Unload Me
End Sub