' ------------------------------------------------------------
'  Constants & functions prototypes definitions
' ------------------------------------------------------------
Public Const sFileOpenError = "Can't open the file "

' ---------------------------------------------------------
'   Structures defintions
' ---------------------------------------------------------

' Table's Column Attributes
Public Type SDTblColumn
    Code          As String
    TblCode       As String
    Name          As String
    Label         As String
    Caption       As String
    Datatype      As String
    Length        As Integer
    Mandatory     As Boolean
    LowerValue    As String
    HigherValue   As String
    ListValues    As String
    ServerRule    As String
    DefaultValue  As String
    Format        As String
    OrdinalNumber As Integer
End Type

' Table Attributes
Public Type SDTable
    Code       As String
    Name       As String
    Label      As String
    ServerRule As String
    nbColumns  As Integer
    Columns()  As SDTblColumn
End Type

' Index's Column Attributes
Public Type SDIdxColumn
    Code      As String
    IdxCode   As String
    TblCode   As String
    SortOrder As String
End Type

' Index Attributes
Public Type SDIndex
    Code      As String
    TblCode   As String
    Unique    As Boolean
    Cluster   As Boolean
    Primary   As Boolean
    Foreign   As Boolean
    nbColumns As Integer
    Columns() As SDIdxColumn
End Type

' Reference Join Attributes
Public Type SDRefJoin
    PrmCode   As String
    FrnCode   As String
End Type

' Reference Attributes
Public Type SDReference
    Code          As String
    PrimaryTable  As String
    ForeignTable  As String
    UpdateRule    As String
    DeleteRule    As String
    nbJoins       As Integer
    Joins()       As SDRefJoin
End Type

' View Attributes
Public Type SDQuery
    Code As    String
    Label As   String
    Text As    String
End Type

' ---------------------------------------------------------
'   Variables definitions
' ---------------------------------------------------------
Public  wspc      As Workspace
Public  dtbsName  As String
Public  fDBOpened As Boolean
Public  DBscript  As String
Public  dtbs      As Database
Private tabl      As TableDef
Private view      As QueryDef
Private coln      As Field
Private sLine     As String
Private sLower    As String
Private newLine   As String
Private retCode   As Long

Private sdtabl   As SDTable
Private sdindx   As SDIndex
Private sdrefr   As SDReference
Private sdview   As SDQuery

' Option Explicit
Option Explicit

' ---------------------------------------------------------
'   Ignore a block (begin object...end object)
' ---------------------------------------------------------
Private Sub AC7IgnoreObject()
    ' loop until "end ..." found
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)
        If Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
        ElseIf Mid(sLower, 1, 4) = "end " Then
            Exit Do
        End If
    Loop
End Sub

' ---------------------------------------------------------
'   Read Column Definition for a Table
' ---------------------------------------------------------
Private Sub AC7TableColumn()
    Dim col As SDTblColumn

    ' Increment Column Counter
    sdtabl.nbColumns = sdtabl.nbColumns + 1

    ' Table Code
    col.TblCode = sdtabl.Code
    ' Column Code
    col.Code = Trim(Mid(sLine, 14))

    ' Defaults
    col.Mandatory = False
    col.OrdinalNumber = sdtabl.nbColumns

    ' Column Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End Column
        If Mid(sLower, 1, 10) = "end column" Then
            Exit Do
        ' Ignore objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = Trim(Mid(sLine, 1, nPos - 1))
            sValue = Trim(Mid(sLine, nPos + 1))

            Select Case LCase(sAttribute)
                Case "name"
                    col.Name = sValue
                Case "label"
                    col.Label = sValue
                Case "caption"
						  col.Caption = sValue
                Case "datatype"
                    col.Datatype = sValue
                Case "length"
                    If IsNumeric(sValue) Then col.Length = sValue
                Case "mandatory"
                    If LCase(sValue) = "yes" Then col.Mandatory = True
                Case "lowervalue"
                    col.LowerValue = sValue
                Case "highervalue"
                    col.HigherValue = sValue
                Case "listvalues"
                    col.ListValues = sValue
                Case "serverrule"
                    col.ServerRule = sValue
                Case "defaultvalue"
                    col.DefaultValue = sValue
                Case "format"
                    col.Format = sValue
                Case "ordinalnumber"
                    If IsNumeric(sValue) Then col.OrdinalNumber = sValue
            End Select
        End If
NextAttribute:
    Loop

    ' Add new Column to Collection
    ReDim Preserve sdtabl.Columns(sdtabl.nbColumns)
    sdtabl.Columns(sdtabl.nbColumns) = col
End Sub

' ---------------------------------------------------------
'   Reset Table
' ---------------------------------------------------------
Private Sub AC7TableReset()
    sdtabl.Code = ""
    sdtabl.Name = ""
    sdtabl.Label = ""
	 sdtabl.ServerRule = ""
    sdtabl.nbColumns = 0
End Sub

' ---------------------------------------------------------
'   Read Table Definition
' ---------------------------------------------------------
Private Sub AC7TableLoad()
    ' Table Code
    sdtabl.Code = Trim(Mid(sLine, 13))

    ' Table Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End Table
        If Mid(sLower, 1, 9) = "end table" Then
            Exit Do
        ' Column Attributes
        ElseIf Mid(sLower, 1, 13) = "begin column " Then
            AC7TableColumn
        ' Ignore other objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = LCase(Trim(Mid(sLine, 1, nPos - 1)))
            sValue = Trim(Mid(sLine, nPos + 1))

            If sAttribute = "name" Then
                sdtabl.Name = sValue
            ElseIf sAttribute = "label" Then
                sdtabl.Label = sValue
            ElseIf sAttribute = "serverrule" Then
                sdtabl.ServerRule = sValue
            End If
        End If
NextAttribute:
    Loop
End Sub

' ---------------------------------------------------------
'   Add a Property for a Column
' ---------------------------------------------------------
Private Sub AC7AddColProp (tabName As String, colName As String, propName As String, propType As Integer, propValue As Variant)
    Dim prop As Property

    On Error Resume Next
    Set tabl = dtbs.TableDefs(tabName)
    Set coln = tabl.Fields(colName)
    If Err <> 0 Then
       Exit Sub
    End If
    coln.Properties(propName) = propValue
    If Err <> 0 Then
        On Error Resume Next
        Set prop = coln.CreateProperty(propName, propType, propValue)
        coln.Properties.Append prop
		  On Error GoTo 0
    End If
End Sub

' ---------------------------------------------------------
'   Add a Property for a Query
' ---------------------------------------------------------
Private Sub AC7AddViewProp(viewName As String, propName As String, propType As Integer, propValue As Variant)
    Dim prop As Property

    On Error Resume Next
    Set view = dtbs.QueryDefs(viewName)
    If Err <> 0 Then
       Exit Sub
    End If
    view.Properties(propName) = propValue
    If Err <> 0 Then
        On Error Resume Next
        Set prop = view.CreateProperty(propName, propType, propValue)
        view.Properties.Append prop
        On Error GoTo 0
    End If
End Sub

' ---------------------------------------------------------
'   Add a Property for a Table
' ---------------------------------------------------------
Private Sub AC7AddTabProp (tabName As String, propName As String, propType As Integer, propValue As Variant)
    Dim prop As Property

    On Error Resume Next
    Set tabl = dtbs.TableDefs(tabName)
    If Err <> 0 Then
       Exit Sub
    End If
    tabl.Properties(propName) = propValue
    If Err <> 0 Then
        On Error Resume Next
        Set prop = tabl.CreateProperty(propName, propType, propValue)
        tabl.Properties.Append prop
        On Error GoTo 0
    End If
End Sub

' ---------------------------------------------------------
'   Build & Add TableDef
' ---------------------------------------------------------
Private Sub AC7BuildTableDef()
    Dim iColumn As Integer
    Dim col     As SDTblColumn
    Dim fld     As Field
    Dim nType   As Long
    Dim nLen    As Long
    Dim autoInc As Boolean

    ' Delete TableDef if Already Exists
    AC7DeleteTable sdtabl.Code

    ' Create New TableDef
    Set tabl = New TableDef
    tabl.Name = sdtabl.Code

    ' Add Columns
    For iColumn = 1 To sdtabl.nbColumns
        col = sdtabl.Columns(iColumn)
        Set fld = New Field
        fld.Name = col.Code

        nLen = 0
        autoInc = False
        Select Case LCase(col.Datatype)
            Case "yesno"
                nType = dbBoolean
            Case "byte"
                nType = dbByte
            Case "integer"
                nType = dbInteger
            Case "longinteger"
                nType = dbLong
            Case "currency"
                nType = dbCurrency
            Case "single"
                nType = dbSingle
            Case "double"
                nType = dbDouble
            Case "datetime"
                nType = dbDate
            Case "text"
                nType = dbText
                nLen = col.Length
            Case "ole"
                nType = dbLongBinary
            Case "memo"
                nType = dbMemo
            Case "counter"
                nType = dbLong
                autoInc = True
            Case Else
                If Left(LCase(col.Datatype), 4) = "text" Then
                    nType = dbText
                    nLen = col.Length
            End If
        End Select

        fld.Type = nType
        fld.Size = nLen
        If autoInc Then fld.Attributes = fld.Attributes + dbAutoIncrField
        fld.DefaultValue = col.DefaultValue
        fld.OrdinalPosition = col.OrdinalNumber
        fld.Required = col.Mandatory

        ' Validation Rule
        If col.LowerValue <> "" And col.HigherValue <> "" Then
           fld.ValidationRule = ">= " & col.LowerValue & " and <= " & col.HigherValue
        ElseIf col.LowerValue <> "" Then
           fld.ValidationRule = ">= " & col.LowerValue
        ElseIf col.HigherValue <> "" Then
           fld.ValidationRule = "<= " & col.HigherValue
        End If
        If col.ListValues <> "" Then
           If fld.ValidationRule  <> "" Then
              fld.ValidationRule = fld.ValidationRule & " and in " & col.ListValues
           Else
              fld.ValidationRule = "in " & col.ListValues
           End If
        End If
        If col.ServerRule <> "" Then
           If fld.ValidationRule  <> "" Then
              fld.ValidationRule = fld.ValidationRule & " and (" & col.ServerRule & ")"
           Else
              fld.ValidationRule = "(" & col.ServerRule & ")"
           End If
        End If
        If Not fld.Required And fld.ValidationRule <> "" Then
           fld.ValidationRule = "(" & fld.ValidationRule & ") or Is Null"
        End If

        ' Add Field to Collection
        tabl.Fields.Append fld
    Next iColumn

    ' Add TableDef
    dtbs.TableDefs.Append tabl

	 ' Add Label on columns
    For iColumn = 1 To sdtabl.nbColumns
        col = sdtabl.Columns(iColumn)
        AC7AddColProp sdTabl.Code, col.Code, "Description", dbText, col.Label
		  AC7AddColProp sdTabl.Code, col.Code, "Caption", dbText, col.Caption
		  AC7AddColProp sdTabl.Code, col.Code, "InputMask", dbText, col.Format
    Next iColumn

	 ' Add Label on table
	 AC7AddTabProp sdTabl.Code,  "Description", dbText, sdTabl.Label
	 AC7AddTabProp sdTabl.Code,  "ValidationRule", dbText, sdTabl.ServerRule
End Sub

' ---------------------------------------------------------
'   Create Table
' ---------------------------------------------------------
Private Sub AC7TableCreate()
    ' Reset Table
    AC7TableReset
    ' Table Attributes
    AC7TableLoad

    Debug.Print "Creation of the Table '" & sdtabl.Code & "'..."

    ' Build & Add TableDef
    AC7BuildTableDef
End Sub

' ---------------------------------------------------------
'   Drop Table
' ---------------------------------------------------------
Private Sub AC7TableDrop()
    Dim tblName As String

    tblName = Trim(Mid(sLine, 12))
    AC7DeleteTable tblName
End Sub

' ---------------------------------------------------------
'   Reset Index
' ---------------------------------------------------------
Private Sub AC7IndexReset()
    sdindx.Code = ""
    sdindx.TblCode = ""
    sdindx.Unique = False
    sdindx.Cluster = False
    sdindx.Primary = False
    sdindx.Foreign = False
    sdindx.nbColumns = 0
End Sub

' ---------------------------------------------------------
'   Read Column Definition for an Index
' ---------------------------------------------------------
Private Sub AC7IndexColumn(sValue As String)
    Dim col As SDIdxColumn

    ' Increment Column Counter
    sdindx.nbColumns = sdindx.nbColumns + 1

    ' Defaults
    col.SortOrder = "+"

    ' Column Code
    col.Code = Trim(Mid(sLine, 14))

    If Mid(sValue, 1, 1) = "+" Then
        col.Code = Mid(sValue, 2)
    ElseIf Mid(sValue, 1, 1) = "-" Then
        col.SortOrder = "-"
        col.Code = Mid(sValue, 2)
    Else
        col.Code = sValue
    End If

    ' Add new Column to Collection
    ReDim Preserve sdindx.Columns(sdindx.nbColumns)
    sdindx.Columns(sdindx.nbColumns) = col
End Sub

' ---------------------------------------------------------
'   Read Index Definition
' ---------------------------------------------------------
Private Sub AC7IndexLoad()
    ' Index Code
    sdindx.Code = Trim(Mid(sLine, 13))

    ' Index Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End Index
        If Mid(sLower, 1, 9) = "end index" Then
            Exit Do
        ' Ignore other objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = LCase(Trim(Mid(sLine, 1, nPos - 1)))
            sValue = Trim(Mid(sLine, nPos + 1))

            Select Case sAttribute
                Case "table"
                    sdindx.TblCode = sValue
                Case "unique"
                    If LCase(sValue) = "unique" Then sdindx.Unique = True
                Case "cluster"
                    If LCase(sValue) = "cluster" Then sdindx.Cluster = True
                Case "primary"
                    If LCase(sValue) = "primarykey" Then sdindx.Primary = True
                Case "foreign"
                    If LCase(sValue) = "foreignkey" Then sdindx.Foreign = True
                Case "field"
                    AC7IndexColumn sValue
            End Select
        End If
NextAttribute:
    Loop
End Sub

' ---------------------------------------------------------
'   Build & Add Index
' ---------------------------------------------------------
Private Sub AC7BuildIndex()
    Dim iColumn As Integer
    Dim col     As SDIdxColumn
    Dim tabl    As TableDef
    Dim indx    As Index
    Dim fld     As Field

    ' Delete index if Already Exists
    AC7DeleteIndex sdindx.Code, sdindx.TblCode

    ' Get the table
    Set tabl = dtbs.TableDefs(sdindx.TblCode)

    ' Create New Index
    Set indx = tabl.CreateIndex(sdindx.Code)
    indx.Clustered = sdindx.Cluster
	 indx.Unique = sdindx.Unique
    indx.Primary = sdindx.Primary
    ' Add Columns
    For iColumn = 1 To sdindx.nbColumns
        col = sdindx.Columns(iColumn)
        Set fld = indx.CreateField(col.Code)
        If col.SortOrder = "-" Then
            fld.Attributes = fld.Attributes + dbDescending
        End If
        indx.Fields.Append fld
    Next iColumn

    ' Add Index TableDef
    tabl.Indexes.Append indx
End Sub

' ---------------------------------------------------------
'   Create Index
' ---------------------------------------------------------
Private Sub AC7IndexCreate()
    ' Reset Index
    AC7IndexReset
    ' Index Attributes
    AC7IndexLoad

    Debug.Print "Creation of the Index '" & sdindx.Code & _
                "' on the Table '" & sdindx.TblCode & "'..."

    ' Build & Add Index
    AC7BuildIndex
End Sub

' ---------------------------------------------------------
'   Drop Index
' ---------------------------------------------------------
Private Sub AC7IndexDrop()
    Dim idxName As String
    Dim tblName As String
    Dim nPos    As Integer

    nPos = InStr(12, sLine, ",")
    If nPos > 0 Then
        idxName = Trim(Mid(sLine, 12, nPos - 12))
        tblName = Trim(Mid(sLine, nPos + 1))
        AC7DeleteIndex idxName, tblName
    End If
End Sub

' ---------------------------------------------------------
'   Reset Reference
' ---------------------------------------------------------
Private Sub AC7ReferenceReset()
    sdrefr.Code = ""
    sdrefr.PrimaryTable = ""
    sdrefr.ForeignTable = ""
    sdrefr.UpdateRule = ""
    sdrefr.DeleteRule = ""
    sdrefr.nbJoins = 0
End Sub

' ---------------------------------------------------------
'   Read Join Definition for a Reference
' ---------------------------------------------------------
Private Sub AC7ReferenceJoin()
    Dim join As SDRefJoin

    ' Increment Column Counter
    sdrefr.nbJoins = sdrefr.nbJoins + 1

    ' Join Code

    ' Defaults

    ' Join Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End Join
        If Mid(sLower, 1, 8) = "end join" Then
            Exit Do
        ' Ignore objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = Trim(Mid(sLine, 1, nPos - 1))
            sValue = Trim(Mid(sLine, nPos + 1))

            Select Case LCase(sAttribute)
                Case "primarycolumn"
                    join.PrmCode = sValue
                Case "foreigncolumn"
                    join.FrnCode = sValue
            End Select
        End If
NextAttribute:
    Loop

    ' Add new Join to Collection
    ReDim Preserve sdrefr.Joins(sdrefr.nbJoins)
    sdrefr.Joins(sdrefr.nbJoins) = join
End Sub

' ---------------------------------------------------------
'   Read Reference Definition
' ---------------------------------------------------------
Private Sub AC7ReferenceLoad()
    ' Index Code
    sdrefr.Code = Trim(Mid(sLine, 17))

    ' Reference Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End Reference
        If Mid(sLower, 1, 13) = "end reference" Then
            Exit Do
        ' Join Attributes
        ElseIf Mid(sLower, 1, 10) = "begin join" Then
            AC7ReferenceJoin
        ' Ignore other objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = LCase(Trim(Mid(sLine, 1, nPos - 1)))
            sValue = Trim(Mid(sLine, nPos + 1))

            Select Case sAttribute
                Case "primarytable"
                    sdrefr.PrimaryTable = sValue
                Case "foreigntable"
                    sdrefr.ForeignTable = sValue
                Case "updaterule"
                    sdrefr.UpdateRule = sValue
                Case "deleterule"
                    sdrefr.DeleteRule = sValue
            End Select
        End If
NextAttribute:
    Loop
End Sub

' ---------------------------------------------------------
'   Build & Add Reference
' ---------------------------------------------------------
Private Sub AC7BuildReference()
    Dim iJoin As Integer
    Dim join  As SDRefJoin
    Dim rltn  As Relation
    Dim fld   As Field

    ' Delete relation if Already Exists
    AC7DeleteRelation sdrefr.Code

    ' Create New Relation
    Set rltn = dtbs.CreateRelation(sdrefr.Code)
    rltn.Table = sdrefr.PrimaryTable
    rltn.ForeignTable = sdrefr.ForeignTable
    If LCase(sdrefr.UpdateRule) = "cascade" Then
        rltn.Attributes = rltn.Attributes + dbRelationUpdateCascade
    End If
    If LCase(sdrefr.DeleteRule) = "cascade" Then
        rltn.Attributes = rltn.Attributes + dbRelationDeleteCascade
    End If
    ' Add Joins
    For iJoin = 1 To sdrefr.nbJoins
        join = sdrefr.Joins(iJoin)
        Set fld = rltn.CreateField(join.PrmCode)
        fld.ForeignName = join.FrnCode
        rltn.Fields.Append fld
    Next iJoin

    ' Add Relation
    dtbs.Relations.Append rltn
End Sub

' ---------------------------------------------------------
'   Create Reference
' ---------------------------------------------------------
Private Sub AC7ReferenceCreate()
    ' Reset Reference
    AC7ReferenceReset
    ' Reference Attributes
    AC7ReferenceLoad

    Debug.Print "Creation of the Reference '" & sdrefr.Code & _
                "' between the Primary Table '" & sdrefr.PrimaryTable & _
                "' and the Foreign Table '" & sdrefr.ForeignTable & "'..."

    ' Build & Add Reference
    AC7BuildReference
End Sub

' ---------------------------------------------------------
'   Reset View
' ---------------------------------------------------------
Private Sub AC7ViewReset()
    sdview.Code = ""
    sdview.Text = ""
	 sdview.Label = ""
End Sub

' ---------------------------------------------------------
'   Read View Definition
' ---------------------------------------------------------
Private Sub AC7ViewLoad()
    ' Index Code
    sdview.Code = Trim(Mid(sLine, 12))

    ' View Attributes
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)

        ' End View
        If Mid(sLower, 1, 8) = "end view" Then
            'If sdview.Text <> "" Then sdview.Text = sdview.Text & ";"
            Exit Do
        ' Ignore other objects
        ElseIf Mid(sLower, 1, 6) = "begin " Then
            AC7IgnoreObject
            GoTo NextAttribute
        ' Ignore Syntax Errors
        ElseIf InStr(sLine, "=") = 0 Then
            GoTo NextAttribute
        ' Attribute
        Else
            Dim nPos       As Integer
            Dim sAttribute As String
            Dim sValue     As String

            nPos = InStr(sLine, "=")
            sAttribute = LCase(Trim(Mid(sLine, 1, nPos - 1)))
            sValue = Trim(Mid(sLine, nPos + 1))

            Select Case sAttribute
                Case "label"
					     sdview.Label = sValue
                Case "text"
                    If sdview.Text <> "" Then sdview.Text = sdview.Text & " "
                    sdview.Text = sdview.Text & sValue
            End Select
        End If
NextAttribute:
    Loop
End Sub

' ---------------------------------------------------------
'   Build & Add QueryDef
' ---------------------------------------------------------
Private Sub AC7BuildView()
    Dim iJoin As Integer
    Dim qry   As QueryDef
    Dim fld   As Field

    ' Delete Query if Already Exists
    AC7DeleteQuery sdview.Code

    ' Create New QueryDef
    Set qry = dtbs.CreateQueryDef(sdview.Code, sdview.Text)

    ' Add Label on query
    AC7AddViewProp sdview.Code, "Description", dbText, sdview.Label

    ' Add Query
    ' CreateQueryDef AUTOMATICALLY appendeds it Name is not null
End Sub

' ---------------------------------------------------------
'   Create View
' ---------------------------------------------------------
Private Sub AC7ViewCreate()
    ' Reset View
    AC7ViewReset
    ' View Attributes
    AC7ViewLoad

    Debug.Print "Creation of the View '" & sdview.Code & "'..."

    ' Build & Add View
    AC7BuildView
End Sub

' ---------------------------------------------------------
'   Drop View
' ---------------------------------------------------------
Private Sub AC7ViewDrop()
    Dim qryName As String

    qryName = Trim(Mid(sLine, 11))
    AC7DeleteQuery qryName
End Sub

' ---------------------------------------------------------
'   Execute Script
' ---------------------------------------------------------
Private Sub AC7ExecuteScript()

    ' Ignore errors
    On Error Resume Next

    ' Load loop
    Do While Not EOF(1)
        Line Input #1, sLine
        sLine = Trim(sLine)
        sLower = LCase(sLine)
        ' Ignore comments
        If Mid(sLine, 1, 1) = "'" Then GoTo NextLine
        ' Drop Table
        If Mid(sLower, 1, 11) = "drop table " Then
            AC7TableDrop
        ' Table
        ElseIf Mid(sLower, 1, 12) = "begin table " Then
            AC7TableCreate
        ' Drop Index
        ElseIf Mid(sLower, 1, 11) = "drop index " Then
            AC7IndexDrop
        ' Index
        ElseIf Mid(sLower, 1, 12) = "begin index " Then
            AC7IndexCreate
        ' Reference
        ElseIf Mid(sLower, 1, 16) = "begin reference " Then
            AC7ReferenceCreate
        ' Drop View
        ElseIf Mid(sLower, 1, 10) = "drop view " Then
            AC7ViewDrop
        ' View
        ElseIf Mid(sLower, 1, 11) = "begin view " Then
            AC7ViewCreate
        End If
NextLine:
    Loop

    ' Close the file
    Close #1
End Sub

' ---------------------------------------------------------
'   Drop a Table
' ---------------------------------------------------------
Private Sub AC7DeleteTable(ByVal tabName As String)
    On Error Resume Next
    dtbs.TableDefs.Delete tabName
    retCode = Err
    'On Error GoTo 0
End Sub

' ---------------------------------------------------------
'   Drop an Index
' ---------------------------------------------------------
Private Sub AC7DeleteIndex(ByVal idxName As String, ByVal tabName As String)
    On Error Resume Next
    dtbs.TableDefs(tabName).Indexes.Delete idxName
    retCode = Err
    'On Error GoTo 0
End Sub

' ---------------------------------------------------------
'   Drop a Relation
' ---------------------------------------------------------
Private Sub AC7DeleteRelation(ByVal relName As String)
    On Error Resume Next
    dtbs.Relations.Delete relName
    retCode = Err
    'On Error GoTo 0
End Sub

' ---------------------------------------------------------
'   Drop a View
' ---------------------------------------------------------
Private Sub AC7DeleteQuery(ByVal qryName As String)
    On Error Resume Next
    dtbs.QueryDefs.Delete qryName
    retCode = Err
    'On Error GoTo 0
End Sub

' ---------------------------------------------------------
'   Get the default script
' ---------------------------------------------------------
Public Function AC7GetDefScript() As String
    AC7GetDefScript = "c:\webshare\wwwroot\rem\database\crebas.dat"
End Function

' ---------------------------------------------------------
'   Get the default database
' ---------------------------------------------------------
Public Function AC7GetDefDatabase() As String
    AC7GetDefDatabase = "rem_web.mdb"
End Function

' ---------------------------------------------------------
'   Initialize the database
' ---------------------------------------------------------
Public Sub AC7OpenDatabase()
    newLine = vbCrLf
    fDBOpened = False

    ' Open the database
    Debug.Print "Open the database '" & dtbsName & "' ..."
    On Error Resume Next
    Set dtbs = wspc.OpenDatabase(dtbsName, True, False, "")
    retCode = Err
    On Error GoTo 0
    If  retCode <> 0 Then
       On Error Resume Next
       Set dtbs = wspc.CreateDatabase(dtbsName, dbLangGeneral)
       retCode = Err
       On Error GoTo 0
    End If
    AC7TestError retCode
    fDBOpened = True
End Sub

' ---------------------------------------------------------
'   Procedure to update the database
' ---------------------------------------------------------
Public Sub Create()
    ' Initialize the database
    Set wspc = DBEngine.Workspaces(0)
    dtbsName = AC7GetDefDatabase
    Set dtbs = wspc.Databases(0)
    if (dtbs.Name <> dtbsName) Then AC7OpenDatabase

    ' Begin transaction
    wspc.BeginTrans

    ' Open the script file
    If DBScript = "" Then DBScript = AC7GetDefScript
    Open DBscript For Input As #1

    ' Update the database from the script
    AC7ExecuteScript

    ' Close the script file
    Close #1

    ' Close the database
    AC7CloseDatabase

    ' Commit transaction
    wspc.CommitTrans

    ' End of program
    Debug.Print newLine & "The database is well created"
    MsgBox "The database '" & dtbsName & "' is well created. To see the new table, you must refresh the Data Manager.", vbOKOnly, "Message"
    End
End Sub

' ---------------------------------------------------------
'   Close the current database
' ---------------------------------------------------------
Private Sub AC7CloseDatabase()
    If fDBOpened Then
       dtbs.Close
       fDBOpened = False
    End If
End Sub

' ---------------------------------------------------------
'   Display the error message
' ---------------------------------------------------------
Private Sub AC7TestError(ret As Long)
    If ret = 0 Then Exit Sub
    If ret < 0 Then ret = -ret

    Debug.Print newLine & "Error : " & Error$(ret) & "."

    ' Close the current database
    AC7CloseDatabase

    ' Close the script file
    Close #1

    ' Stop this module module
    Debug.Print newLine & "The database is not created !"
    Stop
End Sub