caccessdatabasereadcreate.cls

Access Database using Visual Basic 6.0

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "cAccessDataBaseReadCreate"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False

Public Sub createDBtemplate(readDBname As String, TemplateFileName As String)
Dim FP As Integer, IDx As Index, TestValue As Variant, Sx As Variant
Dim DB As Database, TD As TableDef, FD As Field, PR As Property
Dim doc As Document, cnt As Container
'--check for existing template name and database---------------------------
If Not FileExist(DBname) Then
    MsgBox "The databse you proposed to read does not exist. Please enter a valid database.", vbCritical + vbOKOnly, "ERROR: File DOES NOT EXIST"
    Exit Sub
End If
If FileExist(TemplateFileName) Then
    If MsgBox("The template file name proposed already exists. Is it ok to over-write the existing file?", vbExclamation + vbYesNo, "TEMPLATE FILE ALREADY EXISTS") = vbNo Then
        Exit Sub
    End If
End If

FP = FreeFile: Open TemplateFileName For Output As #FP
'---add identifer type as first line----------------------------
Write #FP, 0, "This is an Access DataBase profile.", "Identifier", 0, 0
'---open database-----------------------------
Set DB = OpenDatabase(readDBname)
'---add properties to profile---------------------------------------------------
For Each TD In DB.TableDefs
    If TD.Name <> "MSysAccessObjects" And _
       TD.Name <> "MSysACEs" And _
       TD.Name <> "MSysObjects" And _
       TD.Name <> "MSysQueries" And _
       TD.Name <> "MSysRelationships" Then
        Write #FP, 1#, "Begin Table Detail", "***************", 0, 0
        Write #FP, 1.1, TD.Name, "", 0, 0
        Write #FP, 2#, "Begin Field List", "***************", 0, 0
        For Each FD In TD.Fields
            Write #FP, 2.1, FD.Name, "", FD.Type, FD.Size
        Next FD
        Write #FP, 2.9, "End Fields List", "---------------", 0, 0
        For Each FD In TD.Fields
            Write #FP, 3#, FD.Name, "Begin Properties List ***********", 0, 0
            For Each PR In FD.Properties
                If PR.Name <> "" And _
                   PR.Name <> "Name" And _
                   PR.Name <> "Type" And _
                   PR.Name <> "Size" And _
                   PR.Name <> "CollatingOrder" And _
                   PR.Name <> "SourceField" And _
                   PR.Name <> "SourceTable" And _
                   PR.Name <> "DataUpdatable" And _
                   PR.Name <> "FieldSize" Then
                    Err.Clear: On Error Resume Next: TestValue = PR.Value
                    If Not Err Then
                        If IsEmpty(PR.Value) Then
                            Sx = "Empty"
                        ElseIf TypeName(PR.Value) = "String" Then
                            If ChrCount(Chr(34), PR.Value) > 0 Then
                                Sx = Replace(PR.Value, Chr(34), "")
                            Else
                                Sx = PR.Value
                            End If
                        Else
                            Sx = PR.Value
                        End If
                  '      If IsEmpty(Sx) Then Sx = "????????"
                        Write #FP, 3.1, FD.Name, PR.Name, PR.Type, Sx
                    End If
                End If
            Next PR
            Write #FP, 3.9, "End Properties List", "---------------", 0, 0
        Next FD
        For Each IDx In TD.Indexes
            Write #FP, 4#, "Begin Index List", "****************", 0, 0
            For Each FD In IDx.Fields
                Write #FP, 4.1, IDx.Name, FD.Name, IDx.Primary, IDx.Unique
            Next FD
            Write #FP, 4.9, "End Index List", "---------------", 0, 0
        Next IDx
        Write #FP, 1.9, "End Table List", "---------------", 0, 0
    End If
Next TD
'---look for special db identifiers-----------------------------
'Set cnt = DB.Containers!Databases
'On Error Resume Next
'Set doc = cnt.Documents!Userdefined
'On Error Resume Next
'Write #FP, 9.7, "CreatedBy", doc.Properties("CreatedBy"), 10, 0
'Write #FP, 9.8, "DBFileVerify", doc.Properties("DBFileVerify"), 10, 0
'---indicate end of file-------------------------
Write #FP, 9.9, "END OF FILE,"",0,0"
pass1:
Close #FP
DB.Close
End Sub

Public Sub CreateDBfromTemplate(createDBname As String, TemplateFileName As String)
Dim DB As Database, TD As TableDef, FD As Field, PR As Property
Dim IX As Index, FP As Integer, TableName As String
Dim Ltype As Single, S1 As String, S2 As String, Cf As Variant
Dim Var1 As Variant, Var2 As Variant, wrkDefault As Workspace
Dim cnt As Container, doc As Document
CreateDBfromProfile = False
'--make sure template file exists--------------------
If Not FileExist(TemplateFileName) Then
    MsgBox "The template file was not found. Please create a template file.", vbCritical + vbOKOnly, "ERROR: NO TEMPLATE FILE FOUND"
    Exit Sub
End If
'---open profile--------------------------------------
Err.Clear: FP = FreeFile: Open TemplateFileName For Input As #FP
If Err Then Exit Sub
'---read first line of profile and verify proper type------------------------
Input #FP, Ltype, S1, S2, Var1, Var2
If Ltype <> 0 Or S1 <> "This is an Access DataBase profile." Or S2 <> "Identifier" Then
    MsgBox "Input template file is not expected format.", vbCritical + vbOKOnly, "ERROR Function CreateDBfromProfile"
    Close #FP: Exit Sub
End If
'---test to see if database exists------------------------------------
If Dir(createDBname) <> "" Then
    MsgBox "Database: " & createDBname & Chr(13) & _
           "The above database already exists." & Chr(13) & _
           "You must delete this database before it will be created from a profile.", vbCritical + vbOKOnly, "Error, Database Exists"
    Close #FP: Exit Sub
End If
'Kill DBname
'---create new blank database-------------------------
Err.Clear:
Set wrkDefault = DBEngine.Workspaces(0)
Set DB = wrkDefault.CreateDatabase(createDBname, dbLangGeneral, dbEncrypt)
If Err Then
    MsgBox "Could not create new blank database.", vbCritical + vbOKOnly, "ERROR Function CreateDBfromProfile"
    Close #FP: Exit Sub
End If
'---create tables-------------------------------------
Do While Not EOF(FP)
    Input #FP, Ltype, S1, S2, Var1, Var2
    'If Var2 = "Empty" Then Var2 = Empty
    Select Case Ltype
        Case 9.7, 9.8 'add stockfile marker-------------------------------
            Set cnt = DB.Containers!Databases
            Set doc = cnt.Documents!Userdefined
            doc.Properties.Refresh
            Err.Clear: On Error Resume Next
            Set PR = doc.Properties(S1)
            Debug.Print Err.Number
            If Err.Number = 3270 Then
                Set PR = doc.CreateProperty(S1, Var1, S2)
                doc.Properties.Append PR
            Else
                PR = S2
            End If
        Case 1  'begin new table---------------------------------------
            Set TD = Nothing
        Case 1.1 'add new table----------------------------------------
            Err.Clear: Set TD = DB.CreateTableDef(S1)
            If Err Then
                MsgBox "Could not create new table: " & S1 & ".", vbCritical + vbOKOnly, "ERROR Function CreateDBfromProfile"
                Close #FP: DB.Close: Exit Sub
            End If
            TableName = S1
        Case 1.9 'end of table data------------------------------------
        Case 2   'begin field list-------------------------------------
        Case 2.1 'add field--------------------------------------------
            Err.Clear: TD.Fields.Append TD.CreateField(S1, Var1, Var2)
            If Err Then
                MsgBox "Could not create new field: " & S1 & ".", vbCritical + vbOKOnly, "ERROR Function CreateDBfromProfile"
                Close #FP: DB.Close: Exit Sub
            End If
        Case 2.9 'end fields list--------------------------------------
            DB.TableDefs.Append TD
        Case 3  'begin field properties--------------------------------
            Set FD = TD.Fields(S1)
        Case 3.1 'add field property-----------------------------------
            FD.Properties.Refresh
            Set PR = FD.Properties(S2)
            If Err.Number <> 0 Then
                Set PR = FD.CreateProperty(S2, Var1, Var2)
                FD.Properties.Append PR
            End If
            Err.Clear: On Error Resume Next
            PR = Var2
            If Err.Number = 3219 Then
                Set PR = FD.CreateProperty(S2, Var1, Var2)
                FD.Properties.Append PR
            End If
        Case 3.9 'end properties list----------------------------------
            Set FD = Nothing
        Case 4   'begin index list-------------------------------------
        Case 4.1 'add index--------------------------------------------
            Set IX = TD.CreateIndex(S1)
            IX.Fields.Append IX.CreateField(S2)
            IX.Primary = Var1
            IX.Unique = Var2
        Case 4.9 'end index list---------------------------------------
            TD.Indexes.Append IX
        Case 9.9   'end of file------------------------------------------
            DB.Close: Close #FP: CreateDBfromProfile = True: Exit Sub
        Case Else
                MsgBox "Unexpected line input from profile: " & Chr(13) & _
                "Ltype= " & Ltype & Chr(13) & _
                "S1= " & S1 & Chr(13) & _
                "S2= " & S2 & Chr(13) & _
                "Var1= " & Var1 & Chr(13) & _
                "Var2= " & Var2, vbCritical + vbOKOnly, "ERROR Function CreateDBfromProfile"
                DB.Close: Close #FP: Exit Sub
    End Select
Loop
End Sub

Private Function FileExist(ByVal PathFile As String) As Boolean
    If Dir(PathFile) = "" Then FileExist = False Else FileExist = True
    On Error GoTo 0
End Function

'-----use this for VB5-----------------------------------------------
'Private Function Replace(searchString As String, findString As String, replaceString As String) As String
'Dim curpos As Long
'    curpos = 1
'    Do While InStr(searchString, findString) <> 0
'        curpos = InStr(curpos, searchString, findString)
'        searchString = Left$(searchString, curpos - 1) & replaceString & _
'                       Right$(searchString, Len(searchString) - curpos - Len(findString) + 1)
'    Loop
'    Replace = searchString
'End Function

Private Sub Class_Initialize()
GetOut = False
End Sub

Private Function ChrCount(m_Chr As String, m_Str As String) As Long
Dim i As Long
ChrCount = 0
For i = 1 To Len(m_Str)
    ChrCount = IIf(Mid(m_Str, i, 1) = m_Chr, ChrCount + 1, ChrCount)
Next i
End Function