frmencryptor.frm

大量优秀的vb编程

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.2#0"; "COMDLG32.OCX"
Begin VB.Form frmEncryptor 
   Caption         =   "数据库加密与解密"
   ClientHeight    =   2550
   ClientLeft      =   60
   ClientTop       =   345
   ClientWidth     =   3420
   LinkTopic       =   "Form1"
   ScaleHeight     =   2550
   ScaleWidth      =   3420
   StartUpPosition =   3  '窗口缺省
   Begin MSComDlg.CommonDialog cdlFile 
      Left            =   480
      Top             =   2400
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   393216
      Filter          =   "MS Access Databases (*.mdb)"
   End
   Begin VB.CommandButton cmdClose 
      Cancel          =   -1  'True
      Caption         =   "退出程序"
      Default         =   -1  'True
      Height          =   435
      Left            =   180
      TabIndex        =   3
      Top             =   1920
      Width           =   3075
   End
   Begin VB.CommandButton cmdDecryptDatabase 
      Caption         =   "解密数据库"
      Height          =   435
      Left            =   180
      TabIndex        =   2
      Top             =   1260
      Width           =   3075
   End
   Begin VB.CommandButton cmdEncryptDatabase 
      Caption         =   "加密一个已有的数据库"
      Height          =   435
      Left            =   180
      TabIndex        =   1
      Top             =   720
      Width           =   3075
   End
   Begin VB.CommandButton cmdCreateDatabase 
      Caption         =   "创建一个新的加密的数据库"
      Height          =   435
      Left            =   180
      TabIndex        =   0
      Top             =   180
      Width           =   3075
   End
End
Attribute VB_Name = "frmEncryptor"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

' form level constant declarations of application defined errors
Private Const NO_ERROR = 0
Private Const ERR_DATABASE_EXISTS = 3204


Private Sub Form_Load()

' if there is an error goto the code labeled by ERR_Form_Load
On Error GoTo ERR_Form_Load:

    Dim sUserName As String
    Dim sPassword As String
    
    sUserName = "admin"
    sPassword = ""
    
    With DBEngine
        
        ' set system database path and name
        .SystemDB = "d:\windows\system32\system.mdw"
        
        ' set default passwords
        .DefaultUser = sUserName
        .DefaultPassword = sPassword
    
    End With
    
    With cdlFile
        
        ' set various properties of the common dialog control
        .Flags = cdlOFNExplorer
        .DefaultExt = "mdb"
        
    End With

Exit Sub

ERR_Form_Load:

    ' display the error message for the user
    With Err
        MsgBox "ERROR #" & .Number & ": " & .Description, vbExclamation, _
               "ERROR"
    End With
    
    ' end the application
    cmdClose_Click
    
End Sub

Private Sub cmdCreateDatabase_Click()

' if there is an error goto the code labeled by ERR_cmdCreateDatabase_Click
On Error GoTo ERR_cmdCreateDatabase_Click:

    Dim db As Database
    Dim sNewDatabase As String
    
    With cdlFile
        
        ' get the name of the database to encrypt or decrypt to
        .FileName = ""
        .DialogTitle = "DATABASE TO CREATE"
        .Action = 1
        sNewDatabase = .FileName
        
        ' if the name was not given, abandon task
        If (sNewDatabase = "") Then Exit Sub
        
    End With
    
    ' create the encrypted database
    Set db = DBEngine(0).CreateDatabase(sNewDatabase, dbLangGeneral, dbEncrypt)
    
    ' close the database
    Set db = Nothing
    
ERR_cmdCreateDatabase_Click:

    Dim sMessage As String

    With Err
    
        ' determine error
        Select Case .Number
        
            ' there is no error, inform the user of success
            Case NO_ERROR:
                sMessage = "Database created successfully. "
        
            ' the database already exists
            Case ERR_DATABASE_EXISTS:
                sMessage = "You must chose a database that does not " _
                         & "already exist."
            
            ' unexpected error, inform the user
            Case Else:
                sMessage = "ERROR #" & .Number & ": " & .Description
                
        End Select
        
        ' display the error for the user
        MsgBox sMessage, _
               IIf(.Number = NO_ERROR, vbInformation, vbExclamation), _
               IIf(.Number = NO_ERROR, "SUCCESS", "ERROR")
    
    End With
    
End Sub

Private Sub cmdEncryptDatabase_Click()

    ' call procedure to encrypt database
    Encryptor dbEncrypt
    
End Sub
    
Private Sub cmdDecryptDatabase_Click()

    ' call procedure to decrypt database
    Encryptor dbDecrypt

End Sub

Private Sub cmdClose_Click()

    ' terminate the application
    Unload Me
    
End Sub

Private Sub Encryptor(nAction As Integer)

' if there is an error goto the code labeled by ERR_Encryptor
On Error GoTo ERR_Encryptor:

    Dim sCurDatabase As String
    Dim sNewDatabase As String
    
    Dim sActionString As String
    
    ' create string depending upon action decided by user
    If (nAction = dbEncrypt) Then
        sActionString = "ENCRYPT"
    Else
        sActionString = "DECRYPT"
    End If
    
    With cdlFile
    
        ' get the name of the database to encrypt or decrypt
        .FileName = ""
        .DialogTitle = "DATABASE TO " & sActionString
        .Action = 1
        sCurDatabase = .FileName
        
        ' if the name was not given, abandon task
        If (sCurDatabase = "") Then Exit Sub
        
        ' get the name of the database to encrypt or decrypt to
        .FileName = ""
        .DialogTitle = "DATABASE TO " & sActionString & " TO"
        .Action = 1
        sNewDatabase = .FileName
        
        ' if the name was not given, abandon task
        If (sNewDatabase = "") Then Exit Sub
        
    End With
    
    ' encrypt the database
    DBEngine.CompactDatabase sCurDatabase, sNewDatabase, , nAction
    
ERR_Encryptor:

    Dim sMessage As String

    With Err
    
        ' determine error
        Select Case .Number
        
            ' there is no error, inform the user of success
            Case NO_ERROR:
                sMessage = "Database successfully " _
                         & LCase$(sActionString) & "ed to file '" _
                         & sNewDatabase & "'."
        
            ' the database already exists
            Case ERR_DATABASE_EXISTS:
                sMessage = "You must chose a database that does not " _
                         & "already exist."
            
            ' unexpected error, inform the user
            Case Else:
                sMessage = "ERROR #" & .Number & ": " & .Description
                
        End Select
        
        ' display the error for the user
        MsgBox sMessage, _
               IIf(.Number = NO_ERROR, vbInformation, vbExclamation), _
               IIf(.Number = NO_ERROR, "SUCCESS", "ERROR")
    
    End With
    
End Sub