fmain.frm

《VB6数据库开发指南》所有的例程的源码

VERSION 5.00
Object = "{F9043C88-F6F2-101A-A3C9-08002B2F49FB}#1.1#0"; "COMDLG32.OCX"
Begin VB.Form frmMain 
   BorderStyle     =   3  'Fixed Dialog
   Caption         =   "Create Rules"
   ClientHeight    =   1185
   ClientLeft      =   1590
   ClientTop       =   2535
   ClientWidth     =   3210
   Icon            =   "FMain.frx":0000
   LinkTopic       =   "Form1"
   MaxButton       =   0   'False
   MinButton       =   0   'False
   ScaleHeight     =   1185
   ScaleWidth      =   3210
   ShowInTaskbar   =   0   'False
   Begin VB.CommandButton cmdAddRules 
      Caption         =   "Add Rules"
      Enabled         =   0   'False
      Height          =   465
      Left            =   1170
      TabIndex        =   0
      Top             =   360
      Width           =   1185
   End
   Begin MSComDlg.CommonDialog dlg 
      Left            =   270
      Top             =   360
      _ExtentX        =   847
      _ExtentY        =   847
      _Version        =   327680
   End
   Begin VB.Menu mnuFile 
      Caption         =   "&File"
      Begin VB.Menu mnuFileOpen 
         Caption         =   "&Open"
         Shortcut        =   ^O
      End
      Begin VB.Menu mnuFileBar 
         Caption         =   "-"
      End
      Begin VB.Menu mnuFileExit 
         Caption         =   "E&xit"
         Shortcut        =   ^Q
      End
   End
End
Attribute VB_Name = "frmMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit

Private mdb As Database

Private Sub cmdAddRules_Click()
On Error GoTo ProcError

  Screen.MousePointer = vbHourglass

  AddRules
  MsgBox "Rules Added"
  cmdAddRules.Enabled = False

ProcExit:
  Screen.MousePointer = vbDefault
  Exit Sub

ProcError:
  MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  Resume ProcExit

End Sub

Private Sub mnuFileOpen_Click()
On Error GoTo ProcError

  Dim strDBName As String

  Screen.MousePointer = vbHourglass

  ' use the common dialog to get the db name
  strDBName = GetOpenDBName(dlg)
  If Len(strDBName) Then
    Set mdb = DBEngine(0).OpenDatabase(strDBName)
    cmdAddRules.Enabled = True
  End If

ProcExit:
  Screen.MousePointer = vbDefault
  Exit Sub

ProcError:
  MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  Resume ProcExit

End Sub

Private Sub mnuFileExit_Click()
On Error GoTo ProcError

  Screen.MousePointer = vbHourglass
  
  ' close the database and unload the form
  mdb.Close
  Unload Me

ProcExit:
  Screen.MousePointer = vbDefault
  Exit Sub

ProcError:
  MsgBox "Error: " & Err.Number & vbCrLf & Err.Description
  Resume ProcExit

End Sub

Private Function GetOpenDBName(dlg As CommonDialog) As String
' Get the desired name using the common dialog
On Error GoTo ProcError

  Dim strFileName As String

  ' setup the file save dialog file types
  dlg.InitDir = App.Path
  dlg.DefaultExt = "mdb"
  dlg.DialogTitle = "Open Database"
  dlg.Filter = "VB Databases (*.mdb)|*.mdb"
  dlg.FilterIndex = 1
  ' setup flags
  dlg.Flags = _
    cdlOFNHideReadOnly Or _
    cdlOFNFileMustExist Or _
    cdlOFNPathMustExist
  ' setting CancelError means the control will
  ' raise an error if the user clicks Cancel
  dlg.CancelError = True
  ' show the SaveAs dialog
  dlg.ShowOpen
  ' get the selected name
  strFileName = dlg.filename

ProcExit:
  GetOpenDBName = strFileName
  Exit Function

ProcError:
  strFileName = ""
  Resume ProcExit

End Function
Private Sub AddRules()

  Dim td As TableDef
  Dim fld As Field
  
  ' Advisors table
  ' AdvGradeLevel field
  Set fld = mdb.TableDefs("Advisors").Fields("AdvGradeLevel")
  With fld
    ' require entry
    .Required = True
    ' require a value in a list
    .ValidationRule = _
        "IN ('Freshman', 'Sophomore', 'Junior', 'Senior')"
    .ValidationText = _
        "Grade level must be Freshman, " & _
        "Sophomore, Junior or Senior"
  End With
  Set fld = Nothing
  ' Courses table
  ' CourseDesc field
  mdb.TableDefs("Courses").Fields("CourseDesc").Required = True
  ' Faculty table
  Set td = mdb.TableDefs("Faculty")
  With td
    ' FacFirst required
    .Fields("FacFirst").Required = True
    ' FacLast required
    .Fields("FacLast").Required = True
  End With
  Set td = Nothing
  ' Students table
  Set td = mdb.TableDefs("Students")
  With td
    ' first and last names are required
    .Fields("StFirst").Required = True
    .Fields("StLast").Required = True
    ' table rule - if any part of the
    ' address is provided, all of it
    ' must be provided
    ' the outer IIf evaluates if any field is not null
    ' the inner IIf evalutates if all fields are not null
    .ValidationRule = _
      "IIf(" & _
        "(" & _
          "(Not IsNull([StAddress])) Or " & _
          "(Not IsNull([StCity])) Or " & _
          "(Not IsNull([StState])) Or " & _
          "(Not IsNull([StZIP])) " & _
        "), " & _
        "(IIf(" & _
          "(" & _
            "(Not IsNull([StAddress])) And " & _
            "(Not IsNull([StCity])) And " & _
            "(Not IsNull([StState])) And " & _
            "(Not IsNull([StZIP])) " & _
          "), " & _
          "True, False)" & _
        "), " & _
        "True)"
    .ValidationText = _
        "If provided, the address must be complete."
  End With
  Set td = Nothing

End Sub