Results 1 to 15 of 15

Thread: Utility to generate code to create Access databases using DAO, based on a model file

  1. #1

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Utility to generate code to create Access databases using DAO, based on a model file

    Updated 2021/11/13

    This utility can be used to generate the code to create an Access *.mdb database using DAO, based on a model database file.

    If you want to avoid shipping an empty database with your program, then you can create the new database by code.

    This utility generates the code based on an existing MDB database file.
    It produces the code to create all the tables, Indexes, Fields and Relations (not the particular Access objects like Modules, Queries or Forms).

    Also, the Access description of the fields is preserved.

    There are two caveats that you may want to know:
    1) The UnicodeCompression for Text fields is lost.
    2) The visual position of the tables in the Relations design window of Access is lost.

    You can use the generated code even if you don't use DAO in your program, but you will need to add the reference to "Microsoft DAO 3.6 Object Library".
    Don't worry about the new reference added because it's already installed in all current Windows, so you don't need to add any new file for distribution (as it is also for ADO).
    Attached Files Attached Files
    Last edited by Eduardo-; Nov 13th, 2021 at 01:19 PM. Reason: Code updated

  2. #2

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    The main function is this one:

    Code:
    ' Generates code to create an Access 97 / 2000 / 2003 database based on a model database file
    ' with Tables, Indexes and Relations
    ' also keeping fields descriptions
    Private Function GetDatabaseCreationCode(nModelDB As DAO.Database, Optional nPassword As String) As String
        Dim iTemp As String
        Dim iCode As String
        Dim iTable As DAO.TableDef
        Dim iField As DAO.Field
        Dim iIndex As DAO.Index
        Dim iRelation As DAO.Relation
        Dim iProperty As DAO.Property
        Dim iPos As String
        Dim iStr As String
        Dim iBaseName  As String
        Dim iProcedureName As String
        Dim iProcedureNumber As Long
        Dim iCommonDefinitions As String
        Dim iFieldNames() As String
        Dim iFieldDescriptions() As String
        Dim i As Long
        Dim iCodeLength As Long
        
        iBaseName = Dir(Trim(txtPathModelDB.Text))
        iPos = InStrRev(iBaseName, ".")
        If iPos > 0 Then
            iBaseName = Left(iBaseName, iPos - 1)
        End If
        
        iProcedureName = "CreateDB" & iBaseName
        
        ' Generates the code to create the database
        iProcedureNumber = 1
        
        iCommonDefinitions = "    Dim iTable As DAO.TableDef" & vbCrLf
        iCommonDefinitions = iCommonDefinitions & "    Dim iField As DAO.Field" & vbCrLf
        iCommonDefinitions = iCommonDefinitions & "    Dim iIndex As DAO.Index" & vbCrLf
        iCommonDefinitions = iCommonDefinitions & "    Dim iRelation As DAO.Relation" & vbCrLf
        iCommonDefinitions = iCommonDefinitions & "    Dim iProperty As DAO.Property" & vbCrLf
        
        iCode = "' Creates database " & iBaseName & vbCrLf
        iCode = iCode & "Private Sub " & iProcedureName & " (ByVal nDBFullPath as String, Optional ByVal nDBFormat As DAO.DatabaseTypeEnum)" & vbCrLf
        iCode = iCode & "    Dim iDatabase As DAO.Database" & vbCrLf
        iCode = iCode & iCommonDefinitions
        iCode = iCode & vbCrLf
        iCode = iCode & "    ' Creates the database " & vbCrLf
        
        iCode = iCode & "    If nDBFormat <> 0 Then" & vbCrLf
        iCode = iCode & "        Set iDatabase = DBEngine.CreateDatabase(nDBFullPath, dbLangGeneral " & IIf(nPassword <> "", " & "" ;pwd=" & nPassword & """", "") & ", nDBFormat)" & vbCrLf
        iCode = iCode & "    Else" & vbCrLf
        iCode = iCode & "        Set iDatabase = DBEngine.CreateDatabase(nDBFullPath, dbLangGeneral " & IIf(nPassword <> "", " & "" ;pwd=" & nPassword & """", "") & ")" & vbCrLf
        iCode = iCode & "    End If" & vbCrLf
        
        ' Tables
        iCode = iCode & vbCrLf
        iCode = iCode & "    ' Tables: " & vbCrLf
        For Each iTable In nModelDB.TableDefs
            If (Not ((iTable.Attributes And dbSystemObject) = dbSystemObject)) And (Not (Left(iTable.Name, 4) = "MSys")) Then
                ReDim iFieldNames(0)
                ReDim iFieldDescriptions(0)
                iTemp = "    'Table: " & iTable.Name & vbCrLf
                iTemp = iTemp & "    Set iTable = iDatabase.CreateTableDef(""" & iTable.Name & """)" & vbCrLf
                If iTable.Attributes <> 0 Then
                    iTemp = iTemp & "    iTable.Attributes = " & GetDAOTableDefAttributeStr(iTable.Attributes) & vbCrLf
                End If
                
                ' Fields
                For Each iField In iTable.Fields
                    iTemp = iTemp & "    Set iField = iTable.CreateField(""" & iField.Name & """, " & GetDAODataTypeStr(iField.Type) & ")" & vbCrLf
                    If (iField.Type = dbLong) Then
                        If iField.Attributes <> 0 Then
                            iTemp = iTemp & "    iField.Attributes = " & GetDAOFieldAttributeStr(iField.Attributes) & vbCrLf
                        End If
                    End If
                    iTemp = iTemp & "    iField.Required = " & IIf(iField.Required, "True", "False") & vbCrLf
                    If (iField.Type = dbText) Then
                        iTemp = iTemp & "    iField.Size = " & iField.Size & vbCrLf
                    End If
                    If (iField.Type = dbText) Or (iField.Type = dbMemo) Then
                        iTemp = iTemp & "    iField.AllowZeroLength = " & IIf(iField.AllowZeroLength, "True", "False") & vbCrLf
                    End If
                    If iField.DefaultValue <> "" Then
                        If (iField.Type = dbText) Or (iField.Type = dbMemo) Then
                            iTemp = iTemp & "    iField.DefaultValue = """ & Replace(iField.DefaultValue, """", """""") & """" & vbCrLf
                        ElseIf (iField.Type = dbBoolean) Then
                            iTemp = iTemp & "    iField.DefaultValue = " & IIf((iField.DefaultValue = "Yes") Or (iField.DefaultValue = "Sí") Or (iField.DefaultValue = "Si") Or (iField.DefaultValue = "Verdadero") Or (iField.DefaultValue = "True"), "True", "False") & vbCrLf
                        Else
                            iTemp = iTemp & "    iField.DefaultValue = " & iField.DefaultValue & vbCrLf
                        End If
                    End If
                    
                    iTemp = iTemp & "    iTable.Fields.Append iField" & vbCrLf
                    iTemp = iTemp & vbCrLf
                    
                    ' Access field descriptions must be added later, after the table is appended
                    Set iProperty = Nothing
                    On Error Resume Next
                    Set iProperty = iField.Properties("Description")
                    On Error GoTo 0
                    If Not iProperty Is Nothing Then
                        If iProperty.Value <> "" Then
                            i = UBound(iFieldNames) + 1
                            ReDim Preserve iFieldNames(i)
                            ReDim Preserve iFieldDescriptions(i)
                            iFieldNames(i) = iField.Name
                            iFieldDescriptions(i) = iProperty.Value
                        End If
                    End If
                Next
                
                ' Indexes
                For Each iIndex In iTable.Indexes
                    Set iRelation = Nothing
                    On Error Resume Next
                    Set iRelation = nModelDB.Relations(iIndex.Name)
                    On Error GoTo 0
                    If iRelation Is Nothing Then ' it seems that the relations create a hidden index, that we don't want to add it as a normal index. This hidden index will be created automatically when the relation is created later.
                        iTemp = iTemp & "    Set iIndex = iTable.CreateIndex(""" & iIndex.Name & """)" & vbCrLf
                        For Each iField In iIndex.Fields
                            iTemp = iTemp & "    iIndex.Fields.Append iIndex.CreateField(""" & iField.Name & """)" & vbCrLf
                        Next
                        iTemp = iTemp & "    iIndex.Unique = " & IIf(iIndex.Unique, "True", "False") & vbCrLf
                        iTemp = iTemp & "    iIndex.Primary = " & IIf(iIndex.Primary, "True", "False") & vbCrLf
                        iTemp = iTemp & "    iIndex.Required = " & IIf(iIndex.Required, "True", "False") & vbCrLf
                        iTemp = iTemp & "    iTable.Indexes.Append iIndex" & vbCrLf
                        iTemp = iTemp & vbCrLf
                    End If
                Next
                iTemp = iTemp & "    iDatabase.TableDefs.Append iTable" & vbCrLf
                iTemp = iTemp & vbCrLf
                
                ' Table description
                Set iProperty = Nothing
                On Error Resume Next
                Set iProperty = iTable.Properties("Description")
                On Error GoTo 0
                If Not iProperty Is Nothing Then
                    iTemp = iTemp & "    ' Access table description" & vbCrLf
                    iTemp = iTemp & "    Set iProperty = iTable.CreateProperty (""Description"", dbText, """ & Replace(iProperty.Value, """", """""") & """)" & vbCrLf
                    iTemp = iTemp & "    iTable.Properties.Append iProperty" & vbCrLf
                    iTemp = iTemp & vbCrLf
                End If
                
                ' Add Access field descriptions
                If UBound(iFieldNames) > 0 Then
                    iTemp = iTemp & "    ' Access field descriptions of table " & iTable.Name & vbCrLf
                    For i = 1 To UBound(iFieldNames)
                        iTemp = iTemp & "    Set iProperty = iTable.Fields(""" & iFieldNames(i) & """).CreateProperty (""Description"", dbText, """ & Replace(iFieldDescriptions(i), """", """""") & """)" & vbCrLf
                        iTemp = iTemp & "    iTable.Fields(""" & iFieldNames(i) & """).Properties.Append iProperty" & vbCrLf
                    Next i
                    iTemp = iTemp & vbCrLf
                End If
                
                ' Check if the procedure is getting too long and must be splitted
                If Len(iCode & iTemp) - iCodeLength > 64000 Then
                    iProcedureNumber = iProcedureNumber + 1
                    iCodeLength = iCodeLength + Len(iCode)
                    iCode = iCode & "    " & iProcedureName & "_Part" & iProcedureNumber & " iDatabase"
                    iCode = iCode & vbCrLf
                    iCode = iCode & "End Sub"
                    iCode = iCode & vbCrLf & vbCrLf
                    iCode = iCode & "Private Sub " & iProcedureName & "_Part" & iProcedureNumber & "(iDatabase as DataBase)" & vbCrLf
                    iCode = iCode & iCommonDefinitions
                    iCode = iCode & vbCrLf
                End If
                iCode = iCode & iTemp
            End If
        Next
        
        ' Relations
        If nModelDB.Relations.Count > 0 Then
            iCode = iCode & vbCrLf
            iCode = iCode & "    ' Relations: " & vbCrLf
            For Each iRelation In nModelDB.Relations
                If Not ((iRelation.Attributes And dbSystemObject) = dbSystemObject) And (Not (Left(iRelation.Name, 1) = "{")) Then
                    iTemp = "    'Relation: " & iRelation.Name & vbCrLf
                    
                    iStr = ""
                    If iRelation.Attributes <> 0 Then
                        iStr = GetDAORelationAttributeStr(iRelation.Attributes)
                    End If
                    
                    iTemp = iTemp & "    Set iRelation = iDatabase.CreateRelation(""" & Left(iRelation.Name, 63) & "1" & """, """ & iRelation.Table & """, """ & iRelation.ForeignTable & """" & IIf(iStr <> "", ", " & iStr, "") & ")" & vbCrLf
                    
                    For Each iField In iRelation.Fields
                        iTemp = iTemp & "    Set iField = iRelation.CreateField(""" & iField.Name & """, " & GetDAODataTypeStr(nModelDB.TableDefs(iRelation.Table).Fields(iField.Name).Type) & ")" & vbCrLf
                        iTemp = iTemp & "    iField.ForeignName = """ & iField.ForeignName & """" & vbCrLf
                        iTemp = iTemp & "    iRelation.Fields.Append iField" & vbCrLf
                    Next
                    iTemp = iTemp & "    iDatabase.Relations.Append iRelation" & vbCrLf
                    iTemp = iTemp & vbCrLf
                    
                    ' Check if the procedure is getting too long and must be splitted
                    If Len(iCode & iTemp) - iCodeLength > 64000 Then
                        iProcedureNumber = iProcedureNumber + 1
                        iCode = iCode & "    " & iProcedureName & "_Part" & iProcedureNumber & " iDatabase"
                        iCode = iCode & vbCrLf
                        iCode = iCode & "End Sub"
                        iCode = iCode & vbCrLf & vbCrLf
                        iCode = iCode & "Private Sub " & iProcedureName & "_Part" & iProcedureNumber & "(iDatabase as DataBase)" & vbCrLf
                        iCode = iCode & iCommonDefinitions
                        iCode = iCode & vbCrLf
                    End If
                    iCode = iCode & iTemp
                End If
            Next
        End If
        
        iCode = iCode & "End Sub"
        
        iPos = InStr(iCode, "Part2(")
        If iPos Then
            iCode = Left(iCode, iPos - 1) & Replace(Mid(iCode, iPos), "iDatabase", "nDatabase")
        End If
        
        GetDatabaseCreationCode = iCode
        
    End Function
    Last edited by Eduardo-; Jul 10th, 2017 at 07:03 AM. Reason: Code updated

  3. #3
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Hey Eduardo,

    I haven't looked at your work just yet, but why is UnicodeCompression lost? I've got similar routines that I use quite frequently (DAO 3.60).

    NOTE: Also, my procedures assume that a certain database is open when they,re called (dbTheDatabase). That could be easily modified if one desired.

    This isn't complete, but here's a procedure for adding a field that also sets the UnicodeCompression. The only trick is that you have to go back and set it secondarily (see code).

    Code:
    
    Private Sub DbAddFieldDetails(tdf As DAO.TableDef, TheField As dbFieldAddType, Optional BeforeThisField As String = "AtTheEnd", Optional bIgnoreUnicodeCompression As Boolean = False)
        Dim fdf As DAO.Field ' FieldDef
        Dim i As Long
        Dim iBeforeOrder As Long
        '
        ' Ensure all fields have a unique ordinal value. ie: reset ALL ordinals.
        tdf.Fields.Refresh ' This makes sure that any prior addition is refreshed, especially when order (BeforeThisField) is important.
        For i = 0 To tdf.Fields.Count - 1
            tdf.Fields(i).OrdinalPosition = i
        Next i
        tdf.Fields.Refresh
        '
        If TheField.fdfName = "AutoID" Then
            Set fdf = tdf.CreateField(TheField.fdfName, dbLong, 4)
            fdf.Attributes = fdf.Attributes + dbAutoIncrField
        Else
            ' Field size is ignored by CreateField when it's not needed (according to DAO documentation).
            Set fdf = tdf.CreateField(TheField.fdfName, TheField.fdfType, TheField.fdfSize)
            If TheField.fdfType = dbText Or TheField.fdfType = dbMemo Then
                fdf.AllowZeroLength = TheField.fdfAllowZeroLength
            End If
            If Not IsNull(TheField.fdfDefaultValue) Then
                fdf.DefaultValue = TheField.fdfDefaultValue
            End If
            fdf.Required = TheField.fdfRequired
        End If
        '
        ' If AfterThisField <> "AtTheEnd" Then we need to figure out where to add it.
        If BeforeThisField = "AtTheEnd" Then
            fdf.OrdinalPosition = tdf.Fields.Count
        Else
            iBeforeOrder = tdf.Fields(BeforeThisField).OrdinalPosition
            For i = tdf.Fields.Count - 1 To iBeforeOrder Step -1
                tdf.Fields(i).OrdinalPosition = i + 1
            Next i
            tdf.Fields.Refresh
            fdf.OrdinalPosition = iBeforeOrder
        End If
        '
        tdf.Fields.Append fdf
        '
        If Not bIgnoreUnicodeCompression Then
            ' Created properties must be set AFTER the field is appended.
            If TheField.fdfType = dbText Or TheField.fdfType = dbMemo Then
                DbSetProperty fdf, "UnicodeCompression", dbBoolean, True ' Always just set to true.
            End If
        End If
        '
        tdf.Fields.Refresh
    End Sub
    
    

    I haven't figured out how to make relationships show on the relationship worksheet either. However, you add the tables to the worksheet in MS-Access, and the relationships pop up, so that's never been a big deal for me.

    Best Regards,
    Elroy

    EDIT1: Here's a bit of module level code that might help flesh-out that code above:

    Code:
    
    Private Enum dbDataTypeEnum
        dbText = 10
        dbMemo = 12
        dbBoolean = 1
        dbInteger = 3
        dbLong = 4
        dbSingle = 6
        dbDouble = 7
        dbDate = 8
    End Enum
    #If False Then ' Intellisense fix.
        Public dbText, dbMemo, dbBoolean, dbInteger, dbLong, dbSingle, dbDouble, dbDate
    #End If
    Private Type dbFieldAddType
        fdfName As String
        fdfType As dbDataTypeEnum
        fdfSize As Long
        fdfDefaultValue As Variant
        fdfAllowZeroLength As Boolean ' For strings.
        fdfRequired As Boolean
        fdfDescription As String
    End Type
    
    
    Last edited by Elroy; Jul 9th, 2017 at 08:45 PM.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  4. #4
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Also, I never figured out how to add the description field on the first pass through adding a field. However, I've just got a set of properties for getting it done. I suppose I could have incorporated these more into the above code, but just never did.

    Code:
    
    
    Private Property Get DbFieldDescription(sTable As String, sField As String) As String
        ' Must use error trapping because it'll error if the "Description" property has never been used.
        ' It simply won't exist.
        On Error Resume Next
            DbFieldDescription = dbTheDatabase.TableDefs(sTable).Fields(sField).Properties("Description")
        On Error GoTo 0
    End Property
    
    Private Property Let DbFieldDescription(sTable As String, sField As String, sDesc As String)
        Dim fld As DAO.Field
        Dim prop As DAO.Property
        '
        Set fld = dbTheDatabase.TableDefs(sTable).Fields(sField)
        '
        ' Create property in case it's not already there.
        Set prop = dbTheDatabase.CreateProperty("Description", dbText, " ")
        On Error Resume Next ' In case it already exists.
            fld.Properties.Append prop
        On Error GoTo 0
        '
        fld.Properties("Description") = sDesc
    End Property
    
    

    Also, something else I never quite figured out was how to make a table hidden (without also making it a system table). I thought I had it figured out at one point, but then it seemed to quit working, so I commented it out. It's no biggie, but I do occasionally like having some tables with stuff that's a bit hidden from the user.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  5. #5

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    About the UnicodeCompression issue, I didn't go into much detail in my first post, but the property can be indeed created, but it doesn't work.

    The hidden tables, when they are hidden by VB, they can be created also hidden, but when they are hidden by the Access GUI, I don't know where is that information stored and if accessible from DAO.

  6. #6

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Download updated. A minor bug fixed and a couple of improvements.

  7. #7
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Hi Eduardo,

    I'm not doubting that you've looked into it, but why do you say that UnicodeCompression, set the way I've done it in post #3 doesn't work? I'm not sure I'd know how to easily test it, but, on the properties page in MS-Access, it says it's on for fields I've created with the above code. I'm just wondering why you'd think it's not doing what it's suppose to (i.e., compress ANSI characters to one byte, somewhat similar to a UTF-8 scheme). I'm assuming it just sets a bit somewhere that says, "ohhh, this string is all ANSI, therefore I'll only use one byte per character".

    Also, I'll post what I've attempted to figure out about hidden tables in the past. (I'm not sure you're really interested though. If not, I'll drop it.) Here, I'll just post my "Add Table" code. It's got some good comments in it about that issue:

    Code:
    
    
    Private Sub DbAddTable(sTableName As String, TheFields() As dbFieldAddType, Optional bHidden As Boolean = False)
        '
        ' dbHiddenObject    = &h00000001 ' But this is NOT what it seems.  It's more of a temporary table thing.
        ' dbSystemObject    = &h00000002
        ' dbAttachExclusive = &h00010000
        ' dbAttachSavePWD   = &h00020000
        ' dbAttachedODBC    = &h20000000
        ' dbAttachedTable   = &h40000000
        ' dbTrueHidden      = &h80000000 ' I made this name up.  This is the true hidden bit.  (But it seems to also force &H2.)
        '
        ' Make sure database is open, and EXCLUSIVE access is a good idea.
        ' The database variable must be global, and is named dbTheDatabase.
        ' Fields are added in the order in which they appear in TheFields.
        Dim tdf As DAO.TableDef ' TableDef
        Dim fdf As DAO.Field ' FieldDef
        Dim i As Long
        '
        ' There is a dbHiddenObject attribute but this attribute is NOT what it seems.
        ' This is used to create temporary tables that are deleted upon the next database compression.
        ' Also, tables created with this attribute are COMPLETELY hidden and will not even show when
        ' other hidden tables show.  In other words, do NOT use the dbHiddenObject attribute.
        ' The REAL hidden bit is &H80000000, as is shown in the code below.
        '
        Set tdf = dbTheDatabase.CreateTableDef(sTableName)
        For i = LBound(TheFields) To UBound(TheFields)
            DbAddFieldDetails tdf, TheFields(i), , True
        Next i
        '
        dbTheDatabase.TableDefs.Append tdf
        ' The attributes are initially &H0.
        '
        ' The following is definitely NOT working.  It turns it into a system table (&H80000002), but this wasn't always the case.
    
        'If bHidden Then
        '    '
        '    ' But, for some reason (maybe a Windows update), setting to &H80000000 forces the &H00000002 bit,
        '    ' which makes it an Access System table.  And then, there are permissions issues to delete the table.
        '    ' However, and this is strange, once you set the &H80000000 bit, and then set it back to &H0,
        '    ' the table stays hidden.  This is all rather mysterious.  Apparently, there's some other "Hidden" bit.
        '    '
        '    ' Also, under some circumstances, an error is thrown when trying to do this.
        '    On Error Resume Next
        '        tdf.Attributes = &H80000000 ' This uses the REAL hidden bit, and not dbHiddenObject.
        '        dbTheDatabase.TableDefs.Refresh
        '        tdf.Attributes = &H0
        '        dbTheDatabase.TableDefs.Refresh
        '    On Error GoTo 0
        'Else
            dbTheDatabase.TableDefs.Refresh
        'End If
        '
        ' Now we have to go back and set the unicode compression on the text/memo fields.
        For i = LBound(TheFields) To UBound(TheFields)
            If TheFields(i).fdfType = dbText Or TheFields(i).fdfType = dbMemo Then
                Set fdf = tdf.Fields(TheFields(i).fdfName)
                DbSetProperty fdf, "UnicodeCompression", dbBoolean, True ' Always just set to true.
                tdf.Fields.Refresh
            End If
        Next i
    End Sub
    
    
    Best Regards,
    Elroy

    EDIT1: Again, my particular code assumes the dbTheDatabase is opened exclusive before calling my functions.
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  8. #8

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Quote Originally Posted by Elroy View Post
    Hi Eduardo,

    I'm not doubting that you've looked into it, but why do you say that UnicodeCompression, set the way I've done it in post #3 doesn't work? I'm not sure I'd know how to easily test it, but, on the properties page in MS-Access, it says it's on for fields I've created with the above code.
    Yes, i know that Access says it has UnicodeCompression ON.

    I once had the ilussion that that had worked, until... i don't remember if i suspected or just wanted to test it, and i found that it didn't work.

    Quote Originally Posted by Elroy View Post
    I'm just wondering why you'd think it's not doing what it's suppose to (i.e., compress ANSI characters to one byte, somewhat similar to a UTF-8 scheme). I'm assuming it just sets a bit somewhere that says, "ohhh, this string is all ANSI, therefore I'll only use one byte per character".
    Well, AFAIK, when you change that property, i mean in Access, all the records that are already in the database don't change, but it is applied to the new records that are added or updated.

    What i did to test it was to add many new records with ANSI strings in an database where the UnicodeCompression was set by Access, then compacted the database and checked the size of the database file.

    Then i did the same but with the UnicodeCompression set by VB.
    It was quite larger the database file.

    Quote Originally Posted by Elroy View Post
    Also, I'll post what I've attempted to figure out about hidden tables in the past. (I'm not sure you're really interested though. If not, I'll drop it.) Here, I'll just post my "Add Table" code. It's got some good comments in it about that issue:

    Code:
    
    
    Private Sub DbAddTable(sTableName As String, TheFields() As dbFieldAddType, Optional bHidden As Boolean = False)
        '
        ' dbHiddenObject    = &h00000001 ' But this is NOT what it seems.  It's more of a temporary table thing.
        ' dbSystemObject    = &h00000002
        ' dbAttachExclusive = &h00010000
        ' dbAttachSavePWD   = &h00020000
        ' dbAttachedODBC    = &h20000000
        ' dbAttachedTable   = &h40000000
        ' dbTrueHidden      = &h80000000 ' I made this name up.  This is the true hidden bit.  (But it seems to also force &H2.)
        '
        ' Make sure database is open, and EXCLUSIVE access is a good idea.
        ' The database variable must be global, and is named dbTheDatabase.
        ' Fields are added in the order in which they appear in TheFields.
        Dim tdf As DAO.TableDef ' TableDef
        Dim fdf As DAO.Field ' FieldDef
        Dim i As Long
        '
        ' There is a dbHiddenObject attribute but this attribute is NOT what it seems.
        ' This is used to create temporary tables that are deleted upon the next database compression.
        ' Also, tables created with this attribute are COMPLETELY hidden and will not even show when
        ' other hidden tables show.  In other words, do NOT use the dbHiddenObject attribute.
        ' The REAL hidden bit is &H80000000, as is shown in the code below.
        '
        Set tdf = dbTheDatabase.CreateTableDef(sTableName)
        For i = LBound(TheFields) To UBound(TheFields)
            DbAddFieldDetails tdf, TheFields(i), , True
        Next i
        '
        dbTheDatabase.TableDefs.Append tdf
        ' The attributes are initially &H0.
        '
        ' The following is definitely NOT working.  It turns it into a system table (&H80000002), but this wasn't always the case.
    
        'If bHidden Then
        '    '
        '    ' But, for some reason (maybe a Windows update), setting to &H80000000 forces the &H00000002 bit,
        '    ' which makes it an Access System table.  And then, there are permissions issues to delete the table.
        '    ' However, and this is strange, once you set the &H80000000 bit, and then set it back to &H0,
        '    ' the table stays hidden.  This is all rather mysterious.  Apparently, there's some other "Hidden" bit.
        '    '
        '    ' Also, under some circumstances, an error is thrown when trying to do this.
        '    On Error Resume Next
        '        tdf.Attributes = &H80000000 ' This uses the REAL hidden bit, and not dbHiddenObject.
        '        dbTheDatabase.TableDefs.Refresh
        '        tdf.Attributes = &H0
        '        dbTheDatabase.TableDefs.Refresh
        '    On Error GoTo 0
        'Else
            dbTheDatabase.TableDefs.Refresh
        'End If
        '
        ' Now we have to go back and set the unicode compression on the text/memo fields.
        For i = LBound(TheFields) To UBound(TheFields)
            If TheFields(i).fdfType = dbText Or TheFields(i).fdfType = dbMemo Then
                Set fdf = tdf.Fields(TheFields(i).fdfName)
                DbSetProperty fdf, "UnicodeCompression", dbBoolean, True ' Always just set to true.
                tdf.Fields.Refresh
            End If
        Next i
    End Sub
    
    
    Best Regards,
    Elroy

    EDIT1: Again, my particular code assumes the dbTheDatabase is opened exclusive before calling my functions.
    I do work with hidden tables, and i set them with:
    Code:
    TableDefName.Attributes = TableDefName.Attributes Or dbSystemObject
    And i didn't experience problems with that.

    But, that's not the way that Access hides the tables if you do it from the Access GUI, because that attribute is not set and the table is still hidden.
    In the list of properties of the table i don't see anything particular either.

    Regards.

  9. #9
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Quote Originally Posted by Eduardo- View Post
    What i did to test it was to add many new records with ANSI strings in an database where the UnicodeCompression was set by Access, then compacted the database and checked the size of the database file.

    Then i did the same but with the UnicodeCompression set by VB.
    It was quite larger the database file.
    That sounds like a pretty good test. And it's certainly good to know that it doesn't work, after all these years thinking it did.

    If I get motivated, I'll have to try that test out for myself.

    Take Care,
    Elroy
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  10. #10

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Quote Originally Posted by Elroy View Post
    That sounds like a pretty good test. And it's certainly good to know that it doesn't work, after all these years thinking it did.

    If I get motivated, I'll have to try that test out for myself.

    Take Care,
    Elroy
    Yes, better test it and please post here the results.
    Thanks.

  11. #11

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    I also remember that i checked with an hex editor, and it was using two chanracters per ANSI character, unlike the true Unicode compressed that used only one.

  12. #12
    PowerPoster Elroy's Avatar
    Join Date
    Jun 2014
    Location
    Near Nashville TN
    Posts
    9,853

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Hmmm, well, I was on my way to doing some testing, but now I'm truly puzzled.

    I thought I'd do four tests (creating four separate databases), using a memo field in all cases:

    1. Manually (with MS-Access) create a memo field with "Unicode Compression" set to "Yes".
    2. Manually (with MS-Access) create a memo field with "Unicode Compression" set to "No".
    3. Use VB6 to create a memo field with "Unicode Compression" set to "Yes".
    4. Use VB6 to create a memo field with "Unicode Compression" set to "No".


    And then, in all four cases, I was going to add 100,000 records to each of these databases.

    However, I got the first two databases set up, and got very unexpected results. After adding the 100,000 records, both databases were precisely the same size. This shocked me. I was certain that the "Unicode Compression" set to "Yes" database would be smaller, but it wasn't.

    Also, I did the test two different ways. First, I added a string with 5000 ANSI characters as the memo field. Both databases were the same size, and this was both before and after running "Repair and Compact" on them.

    Then, I found some obscure Microsoft note saying that memo fields weren't compressed unless they resulted in less than 4096 bytes. Therefore, I reduced the ANSI string size to 2000 characters, and ran it all again. However again (both before and after "Repair and Compact") the databases were the same size.

    After all of this, I didn't even bother creating the field from VB6 because there didn't seem to be a need.

    I'm now no longer convinced that the "Unicode Compression" field does anything at all regardless of how it's set.

    Actually, for a straight-up text field, this didn't make sense to me anyway. I had always conceptualized a text field being part of a structure with an assigned amount of space, regardless of how much of it was used. So, why would any compression even make any difference.

    However, memo fields are different. They're more like VB6 strings, with a pointer in the DB record that points to the actual data. In these cases, I could see how "Unicode Compression" might make a difference, but that's certainly not what I found.

    Best Regards,
    Elroy

    EDIT1: Here's the code I was developing for the testing. (I didn't include the actual databases I was using, but they're rather easily conceptualized.) I never got to conditions #3 and #4, because I didn't see the need to go that far.

    Code:
    
    Option Explicit
    
    Private Sub Command1_Click()
        Dim db As DAO.Database
        Dim rs As DAO.Recordset
        Dim i As Long
        Dim s As String
        '
        Set db = DAO.DBEngine.OpenDatabase(App.Path & "\DBtest_UC_Yes_Manual.mdb")
        Set rs = db.OpenRecordset("Table1", dbOpenTable)
        '
        If rs.RecordCount <> 0 Then
            rs.Close
            db.Close
            Exit Sub
        End If
        '
        s = sRandomString(2000) ' Always an ANSI string.
        For i = 1 To 100000
            rs.AddNew
            rs![Field1] = s
            rs.Update
            If i Mod 1000 = 0 Then
                s = sRandomString(2000) ' Change it every 1000 records.
                Label1.Caption = Format$(i): Label1.Refresh
            End If
        Next i
        '
        rs.Close
        db.Close
        '
    End Sub
    
    Private Sub Command2_Click()
        Dim db As DAO.Database
        Dim rs As DAO.Recordset
        Dim i As Long
        Dim s As String
        '
        Set db = DAO.DBEngine.OpenDatabase(App.Path & "\DBtest_UC_No_Manual.mdb")
        Set rs = db.OpenRecordset("Table1", dbOpenTable)
        '
        If rs.RecordCount <> 0 Then
            rs.Close
            db.Close
            Exit Sub
        End If
        '
        s = sRandomString(2000) ' Always an ANSI string.
        For i = 1 To 100000
            rs.AddNew
            rs![Field1] = s
            rs.Update
            If i Mod 1000 = 0 Then
                s = sRandomString(2000) ' Change it every 1000 records.
                Label1.Caption = Format$(i): Label1.Refresh
            End If
        Next i
        '
        rs.Close
        db.Close
        '
    End Sub
    
    Public Function sRandomString(iLength As Integer) As String
        Dim i As Integer
        Dim j As Integer
        Dim s As String
        Static b As Boolean
        '
        If Not b Then
            Randomize
            b = True
        End If
        '
        Do Until j = iLength
            ' This returns an integer from 48 to 83.
            i = Int(36 * Rnd + 48)
            ' Skip over characters between 9 and A.
            If i > 57 Then i = i + 7
            ' Now, i is between 48 and 57 or 65 and 90.
            '                   "0"    "9"   "A"    "Z"
            s = s + Chr$(i)
            j = j + 1
        Loop
        sRandomString = s
    End Function
    
    
    Any software I post in these forums written by me is provided "AS IS" without warranty of any kind, expressed or implied, and permission is hereby granted, free of charge and without restriction, to any person obtaining a copy. To all, peace and happiness.

  13. #13
    Frenzied Member
    Join Date
    Dec 2008
    Location
    Melbourne Australia
    Posts
    1,487

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Will this CodeBank entry be of any assistance -
    http://www.vbforums.com/showthread.p...abase-via-Code

  14. #14

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    Elroy, I had done the test with Text fields (not Memo). And there was difference.

  15. #15

    Thread Starter
    PowerPoster
    Join Date
    Feb 2017
    Posts
    4,997

    Re: Utility to generate code to create Access databases using DAO, based on a model f

    I made a test program and i got some unexpected results:

    Memo fields: added 10000 registers with a field size of 2000 characters each.
    Text fields: added 100000 registers with a field size of 200 characters each.

    Memo field, Access w/o UC: 41,492,480
    Memo field, Access with UC: 41,492,480
    Memo field, VB w/o UC: 41,492,480
    Memo field, VB with UC: 41,492,480
    Text field, Access w/o UC: 24,260,608
    Text field, Access with UC: 24,260,608
    Text field, VB w/o UC: 47,001,600
    Text field, VB with UC: 47,001,600

    Memo fields: added 10000 registers with a field size of 1359 characters each.

    Memo field, Access w/o UC: 41,492,480
    Memo field, Access with UC: 41,492,480
    Memo field, VB w/o UC: 41,492,480
    Memo field, VB with UC: 41,492,480

    Memo fields: added 10000 registers with a field size of 1358 characters each.

    Memo field, Access w/o UC: 21.032.960
    Memo field, Access with UC: 21.032.960
    Memo field, VB w/o UC: 41.492.480
    Memo field, VB with UC: 41.492.480

    Attached is the test program (it has everything ready to run the test).

    What it seems:

    Fields created by Access:
    Unicode compression always works when it is set by Access, but regardless that the property is set to True or False, the ANSI text is always compressed.
    Memo fields are only compressed when the string lenght is below a magic number: 1359. If the string is up to 1358 it is compressed (as I said regardless of the UnicodeCompression property value). If the lenght of the string is 1359 or more, it is not compressed.
    Text fields are always compressed if created in Access.

    Fields created by VB:
    UnicodeCompression never works, for any field type and any string lenght.


    More tests and conclussions:

    Another strange thing is that if the Memo fields store strings of 2000 characters and if they store strings os 1359 characters, the file size is the same: 41,492,480.

    And there is another magic number: 2037. Until 2036 characters lenght, the database file size is 41,492,480.
    2037 and up, the size is: 82,468,864.
    It seems that Memo fields allocate buffer chunks of 2036 characters, because the next step in size is at 4072/4073 and the next at 6108/6109.

    Edit: test program and info updated
    Attached Files Attached Files

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •  



Click Here to Expand Forum to Full Width