frmnewuser.frm

很好的个人数字助理软件代码

         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   765
      TabIndex        =   9
      Top             =   1920
      Width           =   555
   End
   Begin VB.Label Label4 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "密码:"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   885
      TabIndex        =   7
      Top             =   1560
      Width           =   405
   End
   Begin VB.Label Label3 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "用户名:"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   690
      TabIndex        =   5
      Top             =   1200
      Width           =   585
   End
   Begin VB.Label Label2 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "名:"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   1080
      TabIndex        =   3
      Top             =   840
      Width           =   225
   End
   Begin VB.Label Label1 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "姓:"
      BeginProperty Font 
         Name            =   "Arial"
         Size            =   9
         Charset         =   0
         Weight          =   400
         Underline       =   0   'False
         Italic          =   0   'False
         Strikethrough   =   0   'False
      EndProperty
      Height          =   225
      Left            =   1080
      TabIndex        =   1
      Top             =   480
      Width           =   225
   End
   Begin VB.Label lblCaption 
      AutoSize        =   -1  'True
      BackStyle       =   0  'Transparent
      Caption         =   "Hirdhav Digital Diary  -  New User"
      ForeColor       =   &H00000000&
      Height          =   225
      Left            =   200
      TabIndex        =   0
      Top             =   10
      Width           =   2760
   End
   Begin VB.Line Line2 
      BorderWidth     =   2
      X1              =   4920
      X2              =   4920
      Y1              =   240
      Y2              =   4080
   End
   Begin VB.Line Line1 
      BorderWidth     =   2
      X1              =   20
      X2              =   20
      Y1              =   240
      Y2              =   4080
   End
   Begin VB.Shape shapeCaption 
      BackStyle       =   1  'Opaque
      BorderWidth     =   2
      Height          =   255
      Left            =   15
      Top             =   15
      Width           =   4920
   End
End
Attribute VB_Name = "frmNewUser"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Sub Form_Load()
Me.BackColor = RGB(145, 155, 100)
txtFirstName.BackColor = RGB(145, 155, 100)
txtLastName.BackColor = RGB(145, 155, 100)
txtUserName.BackColor = RGB(145, 155, 100)
txtPassword.BackColor = RGB(145, 155, 100)
txtEMail.BackColor = RGB(145, 155, 100)
txtBirthDate.BackColor = RGB(145, 155, 100)
txtQuestion.BackColor = RGB(145, 155, 100)
txtAnswer.BackColor = RGB(145, 155, 100)
shapeAdd.BackColor = RGB(145, 155, 100)
shapeCancel.BackColor = RGB(145, 155, 100)
shapeCaption.BackColor = vbBlack
lblCaption.ForeColor = RGB(145, 155, 100)
End Sub

Private Sub lblAddSupport_Click()
'Check username is entered or blank?
'If blank show err message.
If txtUserName.Text = "" Then
    MsgBox "Please enter username."
    Exit Sub
ElseIf txtUserName.Text = " " Then
    MsgBox "Please enter username."
    Exit Sub
End If

Dim db As Database
Dim ReS As Recordset

Set db = OpenDatabase(App.Path + "\HDD.dat")
Set ReS = db.OpenRecordset("Users")

'First Check whether Username is already exists in
'database or not?
'On Error GoTo ErrHan
Do While Not ReS.EOF
'If Username is already exist show err message
'else add user
        If txtUserName.Text = ReS("Username") Then
            HDDMsgBox "Sorry, Username is Already taken, please select another Username."
            Exit Sub
        End If
ReS.MoveNext
Loop

        ReS.AddNew
        ReS("FirstName") = txtFirstName.Text
        ReS("LastName") = txtLastName.Text
        ReS("Username") = txtUserName.Text
        ReS("Password") = txtPassword.Text
        ReS("Question") = txtQuestion.Text
        ReS("Answer") = txtAnswer.Text
        ReS("BDate") = txtBirthDate.Text
        ReS("EMail") = txtEMail.Text
        ReS.Update
        ChDir App.Path
        ChDir "Data"
        On Error Resume Next
        MkDir txtUserName.Text
        ChDir txtUserName.Text
        'Copy all the Data Tables to the Users Directory.
s:
        ChDir App.Path
        s1 = App.Path + "\Personal.dat"
        s2 = App.Path + "\Memo.dat"
        s3 = App.Path + "\Sch.dat"
        
r:
        ChDir App.Path
        ChDir "Data"
        ChDir txtUserName.Text
        r1 = "Personal.dat"
        r2 = "Memo.dat"
        r3 = "Sch.dat"
        
        FileCopy s1, r1
        FileCopy s2, r2
        FileCopy s3, r3
        
        Set s1 = Nothing
        Set r1 = Nothing
        Set s2 = Nothing
        Set r2 = Nothing
        Set s3 = Nothing
        Set r3 = Nothing
        
        ChDir App.Path
    
    HDDMsgBox "Congratulation, Account is created."
    frmLogin.Show
    Unload Me
    
End Sub

Private Sub lblAddSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblAdd.ForeColor = RGB(145, 155, 100)
shapeAdd.BackColor = vbBlack
End Sub

Private Sub lblAddSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblAdd.ForeColor = vbBlack
shapeAdd.BackColor = RGB(145, 155, 100)
End Sub

Private Sub lblCancelSupport_Click()
frmLogin.Show
Unload Me
End Sub

Private Sub lblCancelSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblCancel.ForeColor = RGB(145, 155, 100)
shapeCancel.BackColor = vbBlack
End Sub

Private Sub lblCancelSupport_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
lblCancel.ForeColor = vbBlack
shapeCancel.BackColor = RGB(145, 155, 100)
End Sub

Private Sub lblCaptionSupport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
DragForm Me
End Sub

Private Sub txtAnswer_KeyPress(KeyAscii As Integer)
'All letters will be in Upercase
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub txtPassword_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
End Sub

Private Sub txtQuestion_KeyPress(KeyAscii As Integer)
'All letters will be in Upercase
KeyAscii = Asc(UCase(Chr(KeyAscii)))
End Sub

Private Sub txtUserName_KeyPress(KeyAscii As Integer)
KeyAscii = Asc(LCase(Chr(KeyAscii)))
If KeyAscii = 32 Then
HDDMsgBox "No spaces are allowed in Username."
SendKeys "{BACKSPACE}"
End If
End Sub