Visual Basic Programmer'…arterly (Limited Edition)/Visual_Basic_Programmers_Journal_VB-CD_Quarterly_Limited_Edition_1995.iso/code/ch28code/generic.cls

Text File | 1995-08-02 | 19.9 KB | 446 lines

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "GenericDB"
Attribute VB_Creatable = True
Attribute VB_Exposed = False
'*********************************************************************
' GENERIC.CLS - A database class with a set of common routines.
'*********************************************************************
Option Explicit
'*********************************************************************
' Class data members
'*********************************************************************
Private WSpace As Workspace     ' Class Workspace
Private DBase As Database       ' Class Database
Private RecSet As Recordset     ' Main Class RecordSet
Private DBFileName As String    ' Filename of the database
Private TBDef As TableDef       ' For creating new tables
Private FieldName As Field      ' For creating new fields
'*********************************************************************
' This Procedure creates the default workspace
'*********************************************************************
Private Sub Class_Initialize()
    Set WSpace = DBEngine.Workspaces(0)
End Sub
'*********************************************************************
' The Recordset, Database, and Workspace are closed when the object
' goes out of scope to prevent corrupting the database.
'*********************************************************************
Private Sub Class_Terminate()
    On Error Resume Next
    RecSet.Close
    DBase.Close
    WSpace.Close
End Sub
'*********************************************************************
' Returns a reference to the workspace.
'*********************************************************************
Public Property Get GetWorkspace() As Workspace
    Set GetWorkspace = WSpace
End Property
'*********************************************************************
' Returns a reference to the database.
'*********************************************************************
Public Property Get GetDatabase() As Database
    Set GetDatabase = DBase
End Property
'*********************************************************************
' Returns the filename of the database that is currently open.
'*********************************************************************
Public Property Get FileName() As String
    FileName = DBFileName
End Property
'*********************************************************************
' Opens a database for use with this class.
'*********************************************************************
Public Sub OpenDB(File$, Optional OpenExclusive, Optional OpenReadOnly)
Dim res%
    '*****************************************************************
    ' If any arguments are missing, add default values.
    '*****************************************************************
    On Error Resume Next
    If Not IsMissing(File) Then DBFileName = File
    If IsMissing(OpenExclusive) Then OpenExclusive = False
    If IsMissing(OpenReadOnly) Then OpenReadOnly = False
    '*****************************************************************
    ' Convert the arguments into valid booleans.
    '*****************************************************************
    OpenExclusive = CBool(OpenExclusive)
    OpenReadOnly = CBool(OpenReadOnly)
    '*****************************************************************
    ' Open the database.
    '*****************************************************************
    Set DBase = WSpace.OpenDatabase(DBFileName, OpenExclusive, _
                                                OpenReadOnly)
    '*****************************************************************
    ' If the database is corrupted, then prompt to repair it.
    '*****************************************************************
    If Err = 3049 Then
        res = MsgBox(Error & vbLf & vbLf & _
                  "Would you like attempt to repair this database?", _
                   vbQuestion + vbYesNo)
        '*************************************************************
        ' If no, then bug out.
        '*************************************************************
        If res = vbNo Then Exit Sub
        '*************************************************************
        ' Otherwise repair it, clear the error flag, and try again.
        '*************************************************************
        Repair DBFileName: Err = 0
        Set DBase = WSpace.OpenDatabase(DBFileName, OpenExclusive, _
                                        OpenReadOnly)
        '*************************************************************
        ' If there is another error, then give up.
        '*************************************************************
        If Err Then
            MsgBox "An attempt to open the database failed!", vbCritical
        End If
    '*****************************************************************
    ' If some other error, then just report it.
    '*****************************************************************
    ElseIf Err <> 0 And Err <> 3049 Then
        MsgBox Error, vbExclamation
    End If
End Sub
'*********************************************************************
' Creates a Recordset for use with this class.
'*********************************************************************
Public Sub CreateRecordSet(Source$, Optional ViewType, Optional Options)
    '*****************************************************************
    ' If any arguments are missing, add default values.
    '*****************************************************************
    If IsMissing(ViewType) Then ViewType = dbOpenDynaset
    If IsMissing(Options) Then
        Set RecSet = DBase.OpenRecordset(Source, CInt(ViewType))
    Else
        Set RecSet = DBase.OpenRecordset(Source, CInt(ViewType), _
                                         CInt(Options))
    End If
End Sub
'*********************************************************************
' Returns a reference to the currently open Recordset.
'*********************************************************************
Public Property Get Data() As Recordset
    Set Data = RecSet
End Property
'*********************************************************************
' Creates a new database.
'*********************************************************************
Public Sub Create(File$)
    If Not IsMissing(File) Then DBFileName = File
    Set DBase = WSpace.CreateDatabase(DBFileName, dbLangGeneral)
End Sub
'*********************************************************************
' Creates a TableDef.
'*********************************************************************
Public Sub MakeTable(TableName As String)
    Set TBDef = DBase.CreateTableDef(TableName)
End Sub
'*********************************************************************
' Returns a reference to the open TableDef.
'*********************************************************************
Public Property Get NewTable() As TableDef
    Set NewTable = TBDef
End Property
'*********************************************************************
' Writes the TableDef to the table, so a new table can be created.
'*********************************************************************
Public Sub AddTable()
    DBase.TableDefs.Append TBDef
    Set TBDef = Nothing
End Sub
'*********************************************************************
' Creates a new field definintion. Other attributes should be set by
' obtaining the NewField reference, and make the changes directly.
'*********************************************************************
Public Sub MakeField(FName$, FType%, Optional FSize)
    Set FieldName = TBDef.CreateField(FName, FType)
    If Not IsMissing(FSize) Then FieldName.Size = CInt(FSize)
End Sub
'*********************************************************************
' Returns a reference to the currently open field definition.
'*********************************************************************
Public Property Get NewField() As Field
    Set NewField = FieldName
End Property
'*********************************************************************
' Writes the field definition to the current TableDef.
'*********************************************************************
Public Sub AddField()
    TBDef.Fields.Append FieldName
    Set FieldName = Nothing
End Sub
'*********************************************************************
' Writes a index to a TableDef.
'*********************************************************************
Public Sub MakeIndex(FldName$, PrimaryKey As Boolean, UniqueKey As Boolean)
Dim NewIndex As New Index      ' For creating new indexes
    With NewIndex
        .Name = "idx" & FldName
        .Fields = FldName
        .Primary = PrimaryKey
        .Unique = IIf(PrimaryKey, True, UniqueKey)
    End With
    TBDef.Indexes.Append NewIndex
End Sub
'*********************************************************************
' Returns all (up to ~32k) of the records of a field in a delimited
' string. This is a useful feature for inserting data into a text box.
'*********************************************************************
Public Function GetData(FName$, ByVal Delimiter$) As String
Dim res$, retStr$
    '*****************************************************************
    ' Move to the first record.
    '*****************************************************************
    On Error Resume Next
    RecSet.MoveFirst
    '*****************************************************************
    ' Build a large (<=~32k) delimited string of the records.
    '*****************************************************************
    Do While Not RecSet.EOF
        res = Trim(RecSet(FName))
        If Len(res) + Len(retStr) > 32001 Then Exit Do
        retStr = retStr & res & Delimiter
        RecSet.MoveNext
    Loop
    '*****************************************************************
    ' Return to the first record, and return the results.
    '*****************************************************************
    RecSet.MoveFirst
    GetData = retStr
End Function
'*********************************************************************
' Same as GetData, but the data is stored in an array.
'*********************************************************************
Public Sub GetArrayData(FName$, retArray() As String)
Dim res$, retStr$, i%
    On Error Resume Next
    Erase retArray
    RecSet.MoveFirst
    Do While Not RecSet.EOF
        res = Trim(RecSet(FName))
        If Len(res) + Len(retStr) > 32001 Then Exit Do
        If Not IsNull(res) Then
            retStr = retStr & res
            ReDim Preserve retArray(i + 1)
            retArray(i) = res
            i = i + 1
        End If
        RecSet.MoveNext
    Loop
    RecSet.MoveFirst
End Sub
'*********************************************************************
' Same as GetData, but the data is loaded into a control. The control
' MUST either be a list or combo box in order for this method to work.
'*********************************************************************
Public Sub GetControlData(FName$, CtrlName As Control)
Dim res, retStr$
    On Error Resume Next
    RecSet.MoveFirst
    Do While Not RecSet.EOF
        res = Trim(RecSet(FName))
        If Len(res) + Len(retStr) > 32001 Then Exit Do
        If Not IsNull(res) Then
            retStr = retStr & res
            CtrlName.AddItem res
        End If
        RecSet.MoveNext
    Loop
    CtrlName.ListIndex = 0
    RecSet.MoveFirst
End Sub
'*********************************************************************
' Adds a new record, or edits an existing one. This method should not
' be used when adding or editing > 20 records (for performance reasons).
'*********************************************************************
Public Sub AddOrEditRecord(ByVal AddRec As Boolean, _
                                           ParamArray FieldPipeValue())
Dim NumItems%, i%, where%, FName$, FValue
    '*****************************************************************
    ' Find out how many parameters were passed. If none, then exit.
    '*****************************************************************
    On Error Resume Next
    NumItems = UBound(FieldPipeValue)
    If IsEmpty(FieldPipeValue(0)) Then Exit Sub
    '*****************************************************************
    ' Determine whether to add or edit the record.
    '*****************************************************************
    If AddRec Then
        RecSet.AddNew
    Else
        RecSet.Edit
        '*************************************************************
        ' If there was no current record, then notify the user.
        '*************************************************************
        If Err = 3021 Then
            MsgBox "Since there is no current record, it can not be edited." _
                    , vbCritical
            Exit Sub
        End If
    End If
    '*****************************************************************
    ' If loop through each parameter.
    '*****************************************************************
    For i = 0 To NumItems
        '*************************************************************
        ' Separate the field name from its value.
        '*************************************************************
        FName = FieldPipeValue(i)
        where = InStr(FName, "|")

        If where = 0 And i > 1 Then
            Exit For
        ElseIf where = 0 And i < 1 Then
            Exit Sub
        End If

        FValue = Mid(FName, where + 1)
        FName = CStr(Left(FName, where - 1))
        '*************************************************************
        ' Determine the record type, and convert the value.
        '*************************************************************
        Select Case RecSet(FName).Type
            Case dbBoolean
                RecSet(FName) = CBool(FValue)
            Case dbByte, dbInteger
                RecSet(FName) = CInt(FValue)
            Case dbLong
                RecSet(FName) = CLng(FValue)
            Case dbCurrency
                RecSet(FName) = CCur(FValue)
            Case dbSingle
                RecSet(FName) = CSng(FValue)
            Case dbDouble
                RecSet(FName) = CDbl(FValue)
            '*********************************************************
            ' Otherwise it must be a dbDate, dbText, dbLongBinary, &
            ' dbMemo.
            '*********************************************************
            Case Else
                where = RecSet(FName).Size
                '*****************************************************
                ' If the record is too long, then clip it.
                '*****************************************************
                If where And (Len(FValue) > where) Then
                    FValue = Left(FValue, where)
                ElseIf Len(FValue) > 32000 Then
                    FValue = Left(FValue, 32000)
                End If
                RecSet(FName) = FValue
        End Select
    Next i
    '*****************************************************************
    ' Complete the transaction.
    '*****************************************************************
    RecSet.Update
End Sub
'*********************************************************************
' Move to the first record.
'*********************************************************************
Public Function MFirst(Optional FName) As String
    On Error Resume Next
    If RecSet.Type = 2 Then Exit Function
    RecSet.MoveFirst
    If Not IsMissing(FName) Then
        MFirst = Trim(RecSet(CStr(FName)))
    End If
End Function
'*********************************************************************
' Move to the last record.
'*********************************************************************
Public Function MLast(Optional FName) As String
    On Error Resume Next
    RecSet.MoveLast
    If Not IsMissing(FName) Then
        MLast = Trim(RecSet(CStr(FName)))
    End If
End Function
'*********************************************************************
' Move to the next record.
'*********************************************************************
Public Function MNext(Optional FName) As String
    On Error Resume Next
    RecSet.MoveNext
    If RecSet.EOF Then RecSet.MoveLast
    If Not IsMissing(FName) Then
        MNext = Trim(RecSet(CStr(FName)))
    End If
End Function
'*********************************************************************
' Move to the previous record.
'*********************************************************************
Public Function MPrev(Optional FName) As String
    On Error Resume Next
    If RecSet.Type = 2 Then Exit Function
    RecSet.MovePrevious
    If RecSet.BOF Then RecSet.MoveFirst
    If Not IsMissing(FName) Then
        MPrev = Trim(RecSet(CStr(FName)))
    End If
End Function
'*********************************************************************
' Locates a record, and returns its result.
'*********************************************************************
Public Function FindRecord(FName$, FindWhat, Optional ByVal _
                           ExactMatch) As Variant
    '*****************************************************************
    ' Determine wheter to find a similar or exact match.
    '*****************************************************************
    On Error Resume Next
    ExactMatch = IIf(IsMissing(ExactMatch), True, ExactMatch)
    '*****************************************************************
    ' Start at the beginning, and find the record.
    '*****************************************************************
    RecSet.MoveFirst
    If ExactMatch Then
        RecSet.FindFirst FName & " = '" & FindWhat & "'"
    Else
        RecSet.FindFirst "[" & FName & "] LIKE '" & FindWhat & "'"
    End If
    '*****************************************************************
    ' If no match, then return "".
    '*****************************************************************
    FindRecord = IIf(RecSet.NoMatch, "", FindRecord = RecSet(FName))
End Function
'*********************************************************************
' Returns a record from a specific field.
'*********************************************************************
Public Function GetRecord(FName$) As Variant
    On Error Resume Next
    GetRecord = RecSet(FName)
End Function
'*********************************************************************
' Repairs and Compacts a damaged database.
'*********************************************************************
Public Sub Repair(FileName$)
Dim BakFileName$, res%
    '*****************************************************************
    ' Make a copy of the database to work on.
    '*****************************************************************
    On Error Resume Next
    BakFileName = Left(FileName, InStr(FileName, ".")) & "BAK"
    FileCopy FileName, BakFileName
    DBEngine.RepairDatabase BakFileName
    '*****************************************************************
    ' If it was successfully repaired, then kill the orginal.
    '*****************************************************************
    If Err = 0 Then
        Kill FileName
        '*************************************************************
        ' Repaired databases should be compacted, so do it now.
        '*************************************************************
        DBEngine.CompactDatabase BakFileName, FileName
        '*************************************************************
        ' If it succeeded, then ask the user if they want to delete
        ' the backup copy.
        '*************************************************************
        If Err = 0 Then
            If MsgBox("Would you like to delete the backup file?", _
                 vbYesNo + vbQuestion) = vbYes Then Kill BakFileName
        End If
    End If
End Sub