newtable.frm

VB6数据库开发指南》的配套源程序

      Left            =   90
      TabIndex        =   0
      Top             =   180
      Width           =   870
   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 Const IllegalCharacters = "[].!'"
Private Const FIELDNAME = 1
Private Const TABLENAME = 2

Private Const BIBLIO_PATH = "D:\Program Files\Microsoft Visual Studio\VB6\Biblio.MDB"

Private Sub Form_Load()
    'Fill the Field Type combo box.
    FillTypeList
End Sub

Sub FillTypeList()
    'Fill the Field Type combo box with types of available fields
    With cboFieldTypes
        .AddItem "Counter"
        .AddItem "Currency"
        .AddItem "Date/Time"
        .AddItem "Memo"
        .AddItem "Number: Byte"
        .AddItem "Number: Integer"
        .AddItem "Number: Long"
        .AddItem "Number: Single"
        .AddItem "Number: Double"
        .AddItem "OLE Object"
        .AddItem "Text"
        .AddItem "Yes/No"
    End With
End Sub

Private Sub cmdListTables_Click()
    'Display the Table List form modally
    frmTableList.Show vbModal
End Sub

Private Sub cmdAddField_Click()
    Dim strFieldType As String
    
    'Check first if the Field Name text box contains a legal name
    If LegalName(FIELDNAME) Then
        'If it does, check if the Field Type has been selected.
        If cboFieldTypes.ListIndex > -1 Then
            'If both criteria are satisfied, store the SQL field type
            'in the strFieldType string.
            Select Case cboFieldTypes.Text
                Case "Counter"
                    strFieldType = "COUNTER"
                Case "Currency"
                    strFieldType = "CURRENCY"
                Case "Date/Time"
                    strFieldType = "DATETIME"
                Case "Memo"
                    strFieldType = "LONGTEXT"
                Case "Number: Byte"
                    strFieldType = "BYTE"
                Case "Number: Integer"
                    strFieldType = "SHORT"
                Case "Number: Long"
                    strFieldType = "LONG"
                Case "Number: Single"
                    strFieldType = "SINGLE"
                Case "Number: Double"
                    strFieldType = "DOUBLE"
                Case "OLE Object"
                    strFieldType = "LONGBINARY"
                Case "Text"
                    strFieldType = "TEXT"
                Case "Yes/No"
                    strFieldType = "BIT"
            End Select
            
            'Add the new field to the Field List list box.
            lstFields.AddItem "[" & txtFieldName & "] " & strFieldType
            
            'Reset the Field Name and Field Type controls.
            txtFieldName = ""
            cboFieldTypes.ListIndex = -1
        Else
            MsgBox "You must select a field type.", vbExclamation
        End If
    End If
End Sub

Function LegalName(intNameType As Integer) As Boolean
    Dim i As Integer
    Dim strObjectName As String
    Dim dbfBiblio As Database, tdfNewTable As TableDef

    On Error GoTo IllegalName
        'Depending on the type of name being checked, store either the
        'field or table name text box contents.
        If intNameType = FIELDNAME Then
            strObjectName = txtFieldName
        Else
            strObjectName = txtTableName
        End If
    
        'If blank, raise an error.
        If Len(strObjectName) = 0 Then Err.Raise 32767
        'If it has a leading space, raise an error.
        If Left$(strObjectName, 1) = " " Then Err.Raise 32766
        'If it contains any of the characters in the IllegalCharacters constant,
        'raise an error
        For i = 1 To Len(IllegalCharacters)
            If InStr(strObjectName, Mid(IllegalCharacters, i, 1)) > 0 Then Err.Raise 32765
        Next i
        'If it contains any ANSI character from Chr$(0) to Chr$(31),
        '(you guessed it) raise an error.
        For i = 0 To 31
            If InStr(strObjectName, Chr(i)) > 0 Then Err.Raise 32764
        Next i
        
        'Check if the field or table name already exists.  If so,
        'raise an error.
        If intNameType = FIELDNAME Then
            For i = 0 To lstFields.ListCount - 1
                If strObjectName = lstFields.List(i) Then Err.Raise 32763
            Next i
        ElseIf intNameType = TABLENAME Then
            Set dbfBiblio = DBEngine.Workspaces(0).OpenDatabase(BIBLIO_PATH)
            For Each tdfNewTable In dbfBiblio.TableDefs
                If tdfNewTable.Name = strObjectName Then Err.Raise 32762
            Next
        End If
        
        'If they've managed to get through all that validation, the function
        'should be True, to indicate success.
        LegalName = True
    On Error GoTo 0
Exit Function

IllegalName:
    Dim strErrDesc As String, context As String

    'Note the use of an IIf statement to reduce code size.
    context = IIf(intNameType = FIELDNAME, "field name", "table name")
    
    'Build an error message based on the user-defined error that occurred.
    Select Case Err.Number
        Case 32767
            strErrDesc = "You must enter a " & context & "."
        Case 32766
            strErrDesc = "The " & context & " cannot begin with a space."
        Case 32765
            strErrDesc = "The " & context & " contains the illegal character " & _
                Mid(IllegalCharacters, i, 1) & "."
        Case 32764
            strErrDesc = "The " & context & " contains the control character " & _
                "with the ANSI value" & Str$(i) & "."
        Case 32763
            strErrDesc = "The field name " & strObjectName & _
                " already exists in the field name list."
        Case 32762
            strErrDesc = "The table name " & strObjectName & _
                " already exists in the database " & BIBLIO_PATH & "."
        Case Else
            ' Visual Basic's default error message.
            strErrDesc = Err.Description
    End Select

    MsgBox strErrDesc, vbExclamation
    
    'The function indicates False, or failure.
    LegalName = False
Exit Function

End Function

Private Sub cmdRemoveField_Click()
    ' If the user has selected a field, remove it from the list.
    ' Otherwise, just ignore the click.
    If lstFields.ListIndex > -1 Then lstFields.RemoveItem lstFields.ListIndex
End Sub

Private Sub cmdCreateTable_Click()
    Dim strSQL As String, strFieldList As String
    Dim i As Integer
    Dim dbfBiblio As Database

    On Error GoTo CreateTableError
        Screen.MousePointer = vbHourglass
        
        If LegalName(TABLENAME) Then
            If lstFields.ListCount > 0 Then
                strFieldList = " (" & lstFields.List(0)
                For i = 1 To lstFields.ListCount - 1
                    strFieldList = strFieldList & ", " & lstFields.List(i)
                Next i
                strFieldList = strFieldList & ") "
                strSQL = "CREATE TABLE [" & txtTableName & "]" & strFieldList
    
                Set dbfBiblio = DBEngine.Workspaces(0).OpenDatabase(BIBLIO_PATH)
                dbfBiblio.Execute (strSQL)
                
                Screen.MousePointer = vbDefault
                MsgBox "Table created successfully."
    
                txtTableName = ""
                lstFields.Clear
            Else
                Screen.MousePointer = vbDefault
                MsgBox "You must define at least one field.", vbExclamation
            End If
        End If
    On Error GoTo 0
Exit Sub

CreateTableError:
    Screen.MousePointer = vbDefault
    MsgBox Error$, vbExclamation
Exit Sub
End Sub

Private Sub cmdClose_Click()
    Dim strErrDesc As String

    ' If the user has entered a partial table definition, make sure that the
    ' user wants to abandon it. If so, end the program.
    If txtTableName <> "" Or lstFields.ListCount > 0 Then
        strErrDesc = "Do you want to abandon operations on the current table?"
        If MsgBox(strErrDesc, vbQuestion + vbYesNo + vbDefaultButton2) = vbYes Then
            End
        End If
    Else
        ' No partial table definition, so just end the program
        End
    End If
End Sub