database.bas

这是一个家庭信息管理的小软件！

  End If
   
RecCountErr:
  If Err.Number <> 0 Then
     RecCount = -1
     Err.Clear
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'Counts The Amount of Administrators in User's Table
'============================================================================================================
Public Function AdminCount() As Long
  Dim aDb As Database
  Dim aRecSet As Recordset
  On Error GoTo AdminCountErr
 
 'Open Database Shared-Readonly
  Set aDb = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
  Set aRecSet = aDb.OpenRecordset("Users")
  
  AdminCount = 0
  
  aRecSet.Fields.Refresh
  
  Do While Not aRecSet.EOF
     If aRecSet.Fields("AccessLevel") = EncryptText("Administrator", Database_Password) Then
        AdminCount = AdminCount + 1
     End If
     aRecSet.MoveNext
  Loop
  
  aRecSet.Close
  aDb.Close
  
AdminCountErr:
  If Err.Number <> 0 Then
     AdminCount = -1
     Err.Clear
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'Used to check if a record exist
'============================================================================================================
Public Function Record_Exist(Table As String, F_Name As String, L_Name As String, Relation_ As String) As Boolean
  Dim rDB As Database
  Dim rRecSet As Recordset
  
  
 'Check if the table is OK
  If (Table_Ok(Database_Path & "\" & Database_Name, Table) = True) Then
     
    'Check The Amount of records in the Table
     If RecCount(Database_Path & "\" & Database_Name, Table) = 1 Then
       'Since there is no records
        Record_Exist = False
        Exit Function
     End If
      
     Set rDB = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
     Set rRecSet = rDB.OpenRecordset(Table)
    'Refresh
     rRecSet.Fields.Refresh
     
     Do While Not rRecSet.EOF
        If (rRecSet.Fields("FirstName") = F_Name) And _
           (rRecSet.Fields("LastName") = L_Name) And _
           (rRecSet.Fields("Relation") = Relation_) Then
           Record_Exist = True
           Exit Function
        End If
        rRecSet.MoveNext
     Loop
     
    'Since it reaches here
     Record_Exist = False
     Exit Function
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'Checks if a recordset is empty
'============================================================================================================
Public Function EmptyRS(RS As Recordset) As Boolean
  EmptyRS = ((RS.BOF = True) And (RS.EOF = True))
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'Checks If A Table Exists
'============================================================================================================
Public Function Table_Exist(TableName As String) As Boolean
  Dim i As Integer
  Dim db As Database
  On Error GoTo Table_Err
  Table_Exist = False
  
 'Open the password protected database
  Set db = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
  For i = 0 To db.TableDefs.Count - 1
   If UCase(db.TableDefs(i).Name) = UCase(TableName) Then
      Table_Exist = True
      db.Close
      Exit Function
   End If
  Next i
Table_Err:
  If Err.Number <> 0 Then
     Table_Exist = False
     Err.Clear
     Exit Function
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'This Function is used to search the "Users" table to see if
'specific user exist
'============================================================================================================
Public Function User_Exist(U_Name As String) As Boolean
  Dim usrDB As Database
  Dim usrRec As Recordset
  Dim tmpStr As String
  On Error GoTo UserExistErr
  
  User_Exist = False
  
 'Open the password protected database
  Set usrDB = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
  Set usrRec = usrDB.OpenRecordset("Users")
  
  usrRec.Fields.Refresh
  usrRec.MoveFirst
  
  If usrRec.RecordCount < 1 Then
     User_Exist = False
     usrRec.Close
     usrDB.Close
     Exit Function
    Else
     Do While Not usrRec.EOF
        tmpStr = DecryptText(usrRec.Fields("LoginName"), Database_Password)
        If (LCase(tmpStr)) = (LCase(U_Name)) Then
           User_Exist = True
           usrRec.Close
           usrDB.Close
           Exit Function
        End If
        usrRec.MoveNext
     Loop
   End If 'usrRec.RecordCount > 0
   
UserExistErr:
  If Err.Number <> 0 Then
     MsgBox "Error : " & Err.Description & " " & Err.Number
     User_Exist = False
     Set usrRec = Nothing
     Set usrDB = Nothing
     Err.Clear
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'This Function Is Used To Remove A Table From The Database
'============================================================================================================
Public Function Remove_Table(TableName As String) As Boolean
  Dim dropDB As Database
  Dim dropTableDef
  Dim dropDB_Open As Boolean
  On Error GoTo DropError
  
  dropDB_Open = False
  
  Set dropDB = OpenDatabase(Database_Path & "\" & Database_Name, False, False, ";pwd=" & Database_Password)
  dropDB_Open = True
  dropDB.Execute "DROP TABLE " & TableName
  dropDB.Close
  Remove_Table = True
  Exit Function

DropError:
  If Err.Number <> 0 Then
     Remove_Table = False
     MsgBox "Error " & Format$(Err.Number) & " dropping table." & _
            Err.Description, vbCritical + vbOKOnly
     Set dropDB = Nothing
     Err.Clear
   End If
End Function
'============================================================================================================
'============================================================================================================

'============================================================================================================
'Used To Remove A Specific user's Record from the "Users"
'Table
'============================================================================================================
Function Delete_User_Record(UName As String) As Boolean
  Dim RS As Recordset
  Dim db As Database
  On Error GoTo Delete_Err
   
 'Open Database The Password Protected Database
  Set db = OpenDatabase(Database_Path & "\" & Database_Name, False, False, ";pwd=" & Database_Password)
 'Open the User table
  Set RS = db.OpenRecordset("SELECT * FROM Users WHERE LoginName = '" & Apostrophe(EncryptText(UName, Database_Password)) & "'")
  RS.Fields.Refresh
 'Check If The User Is Logged In
  If RS.Fields("LoggedIN") = False Then
     With RS
        .Delete  'Delete it
        .Close   'Close it
     End With
     db.Close
     Delete_User_Record = True
    Else
     MsgBox UName & " is currently logged in."
  End If
  
Delete_Err:
  If Err.Number <> 0 Then
     Delete_User_Record = False
     Err.Clear
     Exit Function
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'Used To Completely Remove A User
'Remove the user's from record from the "User's" Table
'Remove The Table That matches the UserName
'============================================================================================================
Public Function Remove_User(User_Name As String) As Boolean
 'First Check if the The User's Record and
 'check if The User Table is ok
  Remove_User = False
 
 If (User_Exist(User_Name) = True) And (Table_Ok(Database_Path & "\" & Database_Name, User_Name) = True) Then
    If (Delete_User_Record(User_Name) = True) And (Remove_Table(User_Name) = True) Then
       Remove_User = True
       Exit Function
      Else
       Remove_User = False
       Exit Function
    End If
   Else
    Remove_User = False
    Exit Function
 End If

End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'This Function is used to Rename a Database Table 'Used
'============================================================================================================
Public Function Rename_Database_Table(Old_Table As String, New_Table As String) As Boolean
  Dim DBase As Database
  Dim TDef As TableDef
  Dim Table_Found As Boolean
  On Error GoTo Rename_Table_Error
   
  Rename_Database_Table = False
  Table_Found = False
  
 'Open The Database
  Set DBase = OpenDatabase(Database_Path & "\" & Database_Name, False, False, ";pwd=" & Database_Password)
   
 'Search For The Matching Table
  For Each TDef In DBase.TableDefs
      If TDef.Name = Old_Table Then
         Table_Found = True
         Exit For
      End If
  Next

  If Table_Found = True Then
    'the varable is still holding the
    'object reference here!
     TDef.Name = New_Table
     DBase.TableDefs.Refresh
  End If

  Set TDef = Nothing
  DBase.Close
  Set DBase = Nothing
  Rename_Database_Table = True
  Exit Function

Rename_Table_Error:
  If Err.Number <> 0 Then
     Rename_Database_Table = False
     MsgBox "Error " & Str(Err.Number) & ". Unable to rename the table." & vbCrLf & Err.Description, vbCritical + vbOKOnly
     Set TDef = Nothing
     Set DBase = Nothing
     Err.Clear
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'This Fuction Is Used To check If A USER is Logged in
'============================================================================================================
Public Function UserLoggedIn(theUserName As String) As Boolean
  Dim tmpUserDb As Database
  Dim tmpUserRec As Recordset
 'On Error Resume Next
  
 'Note : this method is used because The UserName is Unique
  Set tmpUserDb = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
  Set tmpUserRec = tmpUserDb.OpenRecordset("SELECT * FROM Users WHERE LoginName = '" & Apostrophe(EncryptText(theUserName, Database_Password)) & "'")
  tmpUserRec.Fields.Refresh
      
 'Check If Found
  If tmpUserRec.RecordCount > 0 Then
     UserLoggedIn = tmpUserRec.Fields("LoggedIn")
    'Closing
     tmpUserRec.Close
     tmpUserDb.Close
  End If
End Function
'============================================================================================================
'============================================================================================================


'============================================================================================================
'This Function is used to check if someone is logged in
'============================================================================================================
Public Function Users_Logged_In() As Long
  Dim sDbase As Database
  Dim sRecordset As Recordset
  On Error Resume Next
  
  Set sDbase = OpenDatabase(Database_Path & "\" & Database_Name, False, True, ";pwd=" & Database_Password)
  Set sRecordset = sDbase.OpenRecordset("SELECT * FROM Users")
  sRecordset.Fields.Refresh
  sRecordset.MoveFirst
  Users_Logged_In = 0
  
  Do While Not sRecordset.EOF
     If sRecordset.Fields("LoggedIn") = True Then
         Users_Logged_In = Users_Logged_In + 1
    End If
    sRecordset.MoveNext
  Loop
  sRecordset.Close
  sDbase.Close

End Function
'============================================================================================================
'============================================================================================================