Programming Tool Box/SIMS_2.iso/bp_6_93/bonus/dmsrc/module1.txt

Text File | 1995-02-26 | 15KB | 505 lines

Option Explicit

Global gDatabase As database   'Current Database
Global gDatabaseName As String
Global gDatabaseForm As Form
Global gDatabaseType As String

Function addField (table, FName, fType, FSize, FCounter)

    Dim f As New field

    On Error Resume Next

    addField = True
    f.Name = FName
    f.type = fType
    f.size = TypeToSize(fType, FSize)
    If fType = 4 And FCounter = 1 Then f.Attributes = 16

    gDatabase.TableDefs.Refresh
    If Err <> 0 Then
        MsgBox "Error During Refresh Attempt:" + Chr$(13) + Error$, 64, "Data Manager"
        addField = False
        Exit Function
    End If

    gDatabase.TableDefs(table).Fields.Refresh
    If Err <> 0 Then
        MsgBox "Error During Refresh Attempt:" + Chr$(13) + Error$, 64, "Data Manager"
        addField = False
        Exit Function
    End If

    gDatabase.TableDefs(table).Fields.Append f
    If Err <> 0 Then
        MsgBox "Error During Add Field Attempt:" + Chr$(13) + Error$, 64, "Data Manager"
        addField = False
        Exit Function
    End If


End Function

Function AddTable (x As String, FName, fType, FSize, FCounter)

    Dim td As New tabledef
    Dim f As New field
    Dim bInvalid As Integer

    On Error Resume Next
    AddTable = True

    f.Name = FName
    f.type = fType
    f.size = TypeToSize(fType, FSize)
    If fType = 4 And FCounter = 1 Then f.Attributes = 16
    td.Fields.Append f


 ' Do
    bInvalid = False
    If x = "" Or bInvalid = True Then
        x = InputBox("Table Name:", "Create New Table")
    End If

    If x <> "" Then
        td.Name = x
        gDatabase.TableDefs.Append td
        If Err <> 0 Then
            MsgBox "Error During Attempt to Create Table:" + Chr$(13) + Error$, 64, "Data Manager"
            x = ""
         '   If Err = 3010 Or Err = 3125 Then
         '       bInvalid = True
         '   Else
                AddTable = False
                Exit Function
         '   End If
        Else
            RefreshDatabaseWindow
        End If

    Else
        AddTable = False
    End If
 ' Loop While bInvalid = True
End Function

'returns true if database is closed
Function CloseCurrentDatabase ()

    'Used for loop through forms
    Dim i, max, temp, abort As Integer


    'If there is no database open, return true
    If gDatabaseName = "" Then
        CloseCurrentDatabase = True
    Else
        'Unload all query and tabledef forms

        max = forms.Count - 1
        i = 0
        abort = False
        Do While i <= max
            If forms(i).Tag <> "Main" And forms(i).Tag <> "Database" Then
                temp = forms.Count
                Unload forms(i)
                If temp = forms.Count Then
                    abort = True
                    Exit Do
                End If
                max = max - 1
            Else
                i = i + 1
            End If
        Loop

        'If all query and tabledef forms closed, and the user didn't abort,
        'close the database and return Success, else return Failure
        If forms.Count = 2 And Not abort Then
            Unload gDatabaseForm
            CloseCurrentDatabase = True
        Else
            CloseCurrentDatabase = False
        End If
    End If


End Function

Sub OpenADatabase (cmdialog As Control, dataBaseType As String)


    On Error Resume Next

    Dim x As String
    Dim stgpos As Integer

    gDatabaseType = dataBaseType

    If dataBaseType = "ODBC" Then    'Make ODBC Menu visible
        Set gDatabase = OpenDatabase("", 0, 0, "odbc;")
        If Err = 3059 Then
            Exit Sub
        ElseIf Err <> 0 Then
            MsgBox "Could Not Connect:" + Chr$(13) + Error$, 64, "Data Manager"
            Exit Sub
        End If
        x = "ODBC"
        stgpos = InStr(gDatabase.Connect, "DATABASE=")
        If stgpos > 0 Then x = Mid$(gDatabase.Connect, stgpos + 9)
        gDatabaseName = x
        OpenDatabaseWindow x
    ElseIf dataBaseType = "Access" Then
            cmdialog.DefaultExt = "mdb"
            cmdialog.Filename = ""
            cmdialog.DialogTitle = "Open Database"
            cmdialog.CancelError = True
            cmdialog.Filter = "Access (*.mdb)|*.mdb|All Files (*.*)|*.*|"
            cmdialog.Flags = &H4& Or &H1000& 'remove readonly checkbox

            cmdialog.Action = 1
            If Err <> 32755 Then
                Set gDatabase = OpenDatabase(cmdialog.Filename)
                If Err <> 0 Then
                    MsgBox "Could Not Open Database:" + Chr$(13) + Error$, 64, "Data Manager"
                    Exit Sub
                Else
                    'This next line used to read gDatabaseName=gDatabase.Name
                    'but this didn't include the path of the file.
                    gDatabaseName = cmdialog.Filename
                    x = cmdialog.Filetitle
                    OpenDatabaseWindow gDatabaseName
                End If
            End If
    ElseIf dataBaseType = "Btrieve" Then
            cmdialog.Filename = ""
            cmdialog.DefaultExt = "ddf"
            cmdialog.DialogTitle = "Open Database"
            cmdialog.CancelError = True
            cmdialog.Filter = "Btrieve (*.ddf)|*.ddf|All Files (*.*)|*.*|"
            cmdialog.Flags = &H4& Or &H1000&  'remove readonly checkbox

            cmdialog.Action = 1
            If Err <> 32755 Then
                Set gDatabase = OpenDatabase(cmdialog.Filename, 0, 0, "btrieve")
                If Err <> 0 Then
                    MsgBox "Could Not Open Database:" + Chr$(13) + Error$, 64, "Data Manager"
                    Exit Sub
                Else
                    'This next line used to read gDatabaseName=gDatabase.Name
                    'but this didn't include the path of the file.
                    gDatabaseName = cmdialog.Filename
                    x = cmdialog.Filetitle
                    OpenDatabaseWindow gDatabaseName
                End If
            End If
    Else
        Load OpenDBForm
        OpenDBForm.Label1 = "Pick Your " + gDatabaseType + " Directory:"
        OpenDBForm.Show 1
        If OpenDBForm.ExitCondition = "OK" Then
            x = OpenDBForm.Dir1
            If Right(x, 1) <> "\" Then x = x + "\"
            Set gDatabase = OpenDatabase(x, 0, 0, dataBaseType + ";")
            If Err <> 0 Then
                MsgBox "Could Not Open Database:" + Chr$(13) + Error$, 64, "Data Manager"
                Exit Sub
            Else
                gDatabaseName = gDatabase.Name
                x = OpenDBForm.Dir1
                OpenDatabaseWindow x
            End If
        End If
    End If

End Sub

Sub OpenDatabaseWindow (title As Variant)
    Dim x As New dbForm

    Set gDatabaseForm = x
    x.Caption = "Database: " + title
    'gDatabaseName = title
    RefreshDatabaseWindow
    gDatabaseForm.Show


End Sub

Sub OpenNewDatabase (cmdialog As Control, Verfmt As Integer)
'VerFmt=0 means Access 1.1
'VerFmt=1 means Access 1.0

    On Error Resume Next
    cmdialog.DefaultExt = "mdb"
    cmdialog.DialogTitle = "New Database"
    cmdialog.Filename = ""
    cmdialog.CancelError = True
    cmdialog.Filter = "Access (*.mdb)|*.mdb|All Files (*.*)|*.*|"
    cmdialog.Flags = &H4&

    cmdialog.Action = 2
    If Err <> 32755 Then
        Set gDatabase = CreateDatabase(cmdialog.Filename, ";LANGID=0x0809;CP=1252;COUNTRY=0", Verfmt)
        If Err <> 0 Then
            MsgBox "Could Not Create Database:  " + Chr$(13) + Error$, 64, "Data Manager"
            Exit Sub
        End If

        gDatabaseName = cmdialog.Filename

        OpenDatabaseWindow (UCase(cmdialog.Filetitle))
    End If

End Sub

Sub OpenNewTableDesign ()
    On Error Resume Next

    Dim sTableName As String

    sTableName = InputBox("Table Name:", "Create New Table")
    If sTableName = "" Then Exit Sub

    'Check to see if table already exists
    Dim td As New tabledef
    Dim fld As New field

    td.Name = sTableName
    fld.Name = "blank"
    fld.type = 1
    fld.size = 12
    td.Fields.Append fld
    gDatabase.TableDefs.Append td
    If Err <> 0 Then  'Problem adding table of that name
        MsgBox "A table already exists with the name """ & sTableName & """.", 33, "Data Manager"
        Exit Sub
    Else
        gDatabase.TableDefs.Delete sTableName
    End If

    Dim x As New TableForm
    x.Caption = "Table: " & sTableName
    x.TableName = "New Table"

    x.Grid1.ColWidth(0) = 1
    x.Grid1.ColWidth(1) = 3000
    x.Grid1.ColWidth(2) = 2000
    x.Grid1.ColWidth(3) = 2000

    x.Grid1.Row = 0
    x.Grid1.Col = 1: x.Grid1.Text = "Field Name"
    x.Grid1.Col = 2: x.Grid1.Text = "Field Type"
    x.Grid1.Col = 3: x.Grid1.Text = "Field Size"

    x.Grid1.Rows = 11
    x.Grid2.Rows = 10

    x.Grid2.ColWidth(0) = 1
    x.Grid2.ColWidth(1) = 2000
    x.Grid2.ColWidth(2) = 3000
    x.Grid2.ColWidth(3) = 2000
    x.Grid2.ColWidth(4) = 2000

    x.Grid2.Row = 0
    x.Grid2.Col = 1: x.Grid2.Text = "Index Name"
    x.Grid2.Col = 2: x.Grid2.Text = "Index Fields"
    x.Grid2.Col = 3: x.Grid2.Text = "Unique?"
    x.Grid2.Col = 4: x.Grid2.Text = "Primary?"

End Sub

Function OpenTableDesign (table As String)
    On Error Resume Next

    Dim t As tabledef
    Dim i As Integer
    Dim y As String
    Dim x As New TableForm

    OpenTableDesign = True

    x.Caption = "Table: " + table
    x.TableName = table

    x.Grid1.ColWidth(0) = 1
    x.Grid1.ColWidth(1) = 3000
    x.Grid1.ColWidth(2) = 2000
    x.Grid1.ColWidth(3) = 2000

    x.Grid1.Row = 0
    x.Grid1.Col = 1: x.Grid1.Text = "Field Name"
    x.Grid1.Col = 2: x.Grid1.Text = "Field Type"
    x.Grid1.Col = 3: x.Grid1.Text = "Field Size"

    x.Grid2.Rows = 11
    x.Grid2.ColWidth(0) = 1
    x.Grid2.ColWidth(1) = 2000
    x.Grid2.ColWidth(2) = 3000
    x.Grid2.ColWidth(3) = 2000
    x.Grid2.ColWidth(4) = 2000

    x.Grid2.Row = 0
    x.Grid2.Col = 1: x.Grid2.Text = "Index Name"
    x.Grid2.Col = 2: x.Grid2.Text = "Index Fields"
    x.Grid2.Col = 3: x.Grid2.Text = "Unique?"
    x.Grid2.Col = 4: x.Grid2.Text = "Primary?"

    x.Grid2.Rows = 10

    If Not RefreshTableFields(x, table) Then
        MsgBox "Could Not Open Table:" + Chr$(13) + Error$, 64, "Data Manager"
        OpenTableDesign = False
        Unload x
        Exit Function
    End If

    If Not RefreshTableIndexes(x, table) Then
        MsgBox "Could Not Open Table:" + Chr$(13) + Error$, 64, "Data Manager"
        OpenTableDesign = False
        Unload x
        Exit Function
    End If

End Function

Sub RefreshDatabaseWindow ()
    Dim i As Integer

    gDatabaseForm.List1.Clear
    gDatabase.TableDefs.Refresh
    i = 0
    Do While i < gDatabase.TableDefs.Count
        If Left(UCase(gDatabase.TableDefs(i).Name), 4) <> "MSYS" Then
            gDatabaseForm.List1.AddItem gDatabase.TableDefs(i).Name
        End If
        i = i + 1
    Loop
    If gDatabaseForm.List1.ListCount > 0 Then gDatabaseForm.List1.ListIndex = 0
End Sub

Function RefreshTableFields (x As Form, table As String)

    Dim s As snapshot
    Dim i As Integer

    On Error Resume Next
    RefreshTableFields = True

    Set s = gDatabase.ListFields(table)
    If Err <> 0 Then
        RefreshTableFields = False
        Exit Function
    End If

    x.Grid1.Clear
    i = s.RecordCount + 1
    If i > 10 Then
        x.Grid1.Rows = i + 1
    Else
        x.Grid1.Rows = 11
    End If

    i = 1
    Do While Not s.EOF
        x.Grid1.Row = i
        x.Grid1.Col = 1: x.Grid1.Text = s!Name
        x.Grid1.Col = 2: x.Grid1.Text = TypeToName(s!type)
        x.Grid1.Col = 3: x.Grid1.Text = SizeToText(s!type, s!size)
        i = i + 1
        s.MoveNext
    Loop
    s.Close

End Function

Function RefreshTableIndexes (x As Form, table As String)

    Dim i As Integer
    Dim t As tabledef

    On Error Resume Next
    RefreshTableIndexes = True

    gDatabase.TableDefs.Refresh
    gDatabase.TableDefs(table).Indexes.Refresh

    Set t = gDatabase.TableDefs(table)
    x.Grid2.Rows = t.Indexes.Count + 1
    If t.Indexes.Count = 0 Then
        x.Grid2.Rows = 2
        x.Grid2.Row = 1
        x.Grid2.Col = 1: x.Grid2.Text = ""
        x.Grid2.Col = 2: x.Grid2.Text = ""
        x.Grid2.Col = 3: x.Grid2.Text = ""
        x.Grid2.Col = 4: x.Grid2.Text = ""
    End If
    i = 1
    For i = 0 To t.Indexes.Count - 1
        x.Grid2.Row = i + 1
        x.Grid2.Col = 1: x.Grid2.Text = t.Indexes(i).Name
        x.Grid2.Col = 2: x.Grid2.Text = t.Indexes(i).Fields

        x.Grid2.Col = 3
        If t.Indexes(i).Unique Then
            x.Grid2.Text = "Unique"
        Else
            x.Grid2.Text = "Duplicates OK"
        End If

        x.Grid2.Col = 4
        If t.Indexes(i).Primary Then
            x.Grid2.Text = "Primary"
        Else
            x.Grid2.Text = "Not Primary"
        End If
    Next i
    t.Close

End Function

Function SizeToText (fType, FSize)
    If fType = 10 Then
        SizeToText = FSize
    Else
        SizeToText = ""
    End If

End Function

Function TypeToName (x)
    Select Case x
        Case 1: TypeToName = "Boolean"
        Case 2: TypeToName = "Byte"
        Case 3: TypeToName = "Integer"
        Case 4: TypeToName = "Long Integer"
        Case 5: TypeToName = "Currency"
        Case 6: TypeToName = "Single"
        Case 7: TypeToName = "Double"
        Case 8: TypeToName = "Date/Time"
        Case 9: TypeToName = "<Reserved>"
        Case 10: TypeToName = "Text"
        Case 11: TypeToName = "Binary"
        Case 12: TypeToName = "Memo"
    End Select
End Function

Function TypeToSize (fType, FSize)
    Select Case fType
        Case 1: TypeToSize = 1
        Case 2: TypeToSize = 1
        Case 3: TypeToSize = 2
        Case 4: TypeToSize = 4
        Case 5: TypeToSize = 8
        Case 6: TypeToSize = 4
        Case 7: TypeToSize = 8
        Case 8: TypeToSize = 8
        Case 10: TypeToSize = FSize
        Case 11: TypeToSize = 0
        Case 12: TypeToSize = 0
    End Select
End Function