Make a structure-only copy of a table in a new .accdb / change AN to LI (AC2007)

[AOB]

Hi guys,

I want to replicate some of the tables in my BE in a separate database. At this stage, I just want to copy the table structure only (no data). However, I also want to change any autonumber fields to non-incremental long integer fields, before any records get copied across.

Does anybody know how I can change the field type in the new table from AutoNumber to LongInteger using TableDef / Field objects? I know I can do it with DoCmd.RunSQL "ALTER TABLE..." but I'm wary of doing this as the table names are the same in the 'live' BE as they are in the newly created copy and I don't want to accidentally change the attributes of the live

(Although I don't think it's actually possible to change an autonumber field to long integer if there are already records present - however, not willing to test that out!)

Private Function CreateArchiveBE(lngYear) As String
 
  Dim wrk As Workspace
  Dim dbs As Database
  Dim tdf As TableDef
  Dim fld As Field
  Dim objFSO As Object
  Dim arrArchiveTables() As String
  Dim strPath As String
  Dim i As Long
 
  arrArchiveTables = Split(strArchiveTables, ":")
 
  ' Get default Workspace
 
  Set wrk = DBEngine.Workspaces(0)
 
  ' Define Path
 
  strPath = strArchiveFolder & "Archive" & lngYear & ".accdb"
 
  ' Confirm archive does not already exist (exit if found)
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  If objFSO.FileExists(strPath) Then
    CreateArchiveBE = objFSO.GetFile(strPath).Path
    Exit Function
  End If
 
  ' Create a new .accdb file
 
  Set dbs = wrk.CreateDatabase(strPath, dbLangGeneral)
 
  ' Copy the tables in scope from the live to the archive (structure only, no records)
 
  For i = LBound(arrArchiveTables) To UBound(arrArchiveTables)
    DoCmd.TransferDatabase acExport, "Microsoft Access", strPath, acTable, arrArchiveTables(i), arrArchiveTables(i), True
  Next i
 
  ' Important! Need to change autonumber fields to long integers
  ' (to prevent incrementation - retain the identifiers from the live version so they can be related back and forth later)
 
  For Each tdf In dbs.TableDefs
    For Each fld In tdf.Fields
      If fld.Attributes And dbAutoIncrField Then
        ' ?????
      End If
    Next fld
  Next tdf
 
  Set objFSO = Nothing
  Set fld = Nothing
  Set tdf = Nothing
  Set dbs = Nothing
  Set wrk = Nothing
 
End Function

 

[JHB]

..
Does anybody know how I can change the field type in the new table from AutoNumber to LongInteger using TableDef / Field objects?

You can't do that, (so far I know), but you can delete the field and thereafter append a new field with the correct field type, but you've to delete the field index first.

  Dim RememberFieldName As String
  Dim Newfld As Field
  Dim myIndex As Index
..
  For Each fld In tdf.Fields
    If fld.Attributes And dbAutoIncrField Then
      RememberFieldName = fld.Name
      For Each myIndex In tdf.Indexes
        For Each MyField In myIndex.Fields
          If MyField.Name = RememberFieldName Then
            tdf.Indexes.Delete myIndex.Name
            Exit For
          End If
        Next
      Next
      tdf.Fields.Delete RememberFieldName
      Set Newfld = tdf.CreateField(RememberFieldName, dbLong)
       With tdf.Fields
        .Append Newfld
        .Refresh
      End With
    End If
  Next fld
...

But why not use "Alter Table" together with the dbs object?

..
  For Each fld In tdf.Fields
    If fld.Attributes And dbAutoIncrField Then
      dbs.Execute "ALTER TABLE [" & tdf.Name & "] " _
      & "ALTER COLUMN " & fld.Name & " Long;"
    End If
  Next fld
..

 

[AOB]

JHB

Thanks for the response and apologies for the delay in acknowledging...

I actually copped that myself over the weekend but wasn't able to post back - however, in my interim research, I chanced upon a snippet of code for replicating a TableDef. I think I've been able to adjust it so that AutoNumber fields are switched to Long Integers as well (in other words, I've messed around with it and the result appears to be what I'm looking for!)

It's probably not as neat as my original thought (coupled with your dbs.Execute suggestion) but I like the idea that it builds the tables completely from scratch and takes on the properties & indexes of the original, rather than copying everything and then making changes retrospectively. I don't know why exactly, but it sits better with me for some reason?

Here is the link to the original article - I can't take credit for the core code, obviously...

Below is my adaptation of that code (I renamed the variables as I was struggling to keep track of what was what; the lines in blue are my own workaround for detecting AutoNumber fields and changing them to Long Integers)

(For clarity, anything suffixed "Live" is my 'original' backend DB and anything suffixed "Arch" is the data-less, structure-only copy of the backend tables - "Arch" as I intend to use the copy as an archive for old data)

Private Function CopyTableDef(tdfLive As TableDef, dbsArch As Database, Optional strTargetName As String) As Boolean
 
  Dim idxLive As Index
  Dim fldLive As Field
  Dim prpLive As Property
 
  Dim tdfArch As TableDef
  Dim idxArch As Index
  Dim fldArch As Field
  Dim prpArch As Property
 
  Dim intIndex As Integer
  Dim intField As Integer
  Dim intProperty As Integer
 
  If tdfLive.Attributes And dbAttachedODBC Or tdfLive.Attributes And dbAttachedTable Then
 
    CopyTableDef = False
    Exit Function
 
  End If
 
  If strTargetName = "" Then
 
    Set tdfArch = dbsArch.CreateTableDef(tdfLive.Name)
 
  Else
 
    Set tdfArch = dbsArch.CreateTableDef(strTargetName)
 
  End If
 
  ' Copy Jet Properties
 
  On Error Resume Next
 
  For intProperty = 0 To tdfArch.Properties.Count - 1
 
    If tdfArch.Properties(intProperty).Name <> "Name" Then
 
      tdfArch.Properties(intProperty).Value = tdfLive.Properties(intProperty).Value
 
    End If
 
  Next intProperty
 
  On Error GoTo 0
 
  ' Copy Fields
 
  For intField = 0 To tdfLive.Fields.Count - 1
 
    Set fldLive = tdfLive.Fields(intField)
 
    If (fldLive.Attributes And dbSystemField) = 0 Then
 
      Set fldArch = tdfArch.CreateField()
 
      ' Copy Jet Properties
 
      On Error Resume Next
 
      For intProperty = 0 To fldArch.Properties.Count - 1
 
[COLOR=blue]       If fldLive.Properties(intProperty).Name = "Attributes" Then[/COLOR]
 
[COLOR=blue]         If (fldLive.Properties(intProperty).Value And dbAutoIncrField) Then[/COLOR]
 
[COLOR=blue]           fldArch.Properties(intProperty).Value = 1[/COLOR]
 
[COLOR=blue]         Else[/COLOR]
 
[COLOR=blue]           fldArch.Properties(intProperty).Value = fldLive.Properties(intProperty).Value[/COLOR]
 
[COLOR=blue]         End If[/COLOR]
 
[COLOR=blue]       Else[/COLOR]
 
[COLOR=blue]         fldArch.Properties(intProperty).Value = fldLive.Properties(intProperty).Value[/COLOR]
 
[COLOR=blue]       End If[/COLOR]
 
      Next intProperty
 
      On Error GoTo 0
 
      tdfArch.Fields.Append fldArch
 
    End If
 
  Next intField
 
  ' Copy Indexes
 
  For intIndex = 0 To tdfLive.Indexes.Count - 1
 
    Set idxLive = tdfLive.Indexes(intIndex)
 
    If Not idxLive.Foreign Then         ' Foreign indexes are added by relationships
 
      Set idxArch = tdfArch.CreateIndex()
 
      ' Copy Jet Properties
 
      On Error Resume Next
 
      For intProperty = 0 To idxArch.Properties.Count - 1
 
        idxArch.Properties(intProperty).Value = idxLive.Properties(intProperty).Value
 
      Next intProperty
 
      On Error GoTo 0
 
      ' Copy Fields
 
      For intField = 0 To idxLive.Fields.Count - 1
 
        Set fldArch = tdfArch.CreateField(idxLive.Fields(intField).Name, tdfArch.Fields(idxLive.Fields(intField).Name).Type)
 
        dxArch.Fields.Append fldArch
 
      Next intField
 
      tdfArch.Indexes.Append idxArch
 
    End If
 
  Next intIndex
 
  ' Append TableDef
 
  dbsArch.TableDefs.Append tdfArch
 
  ' Copy Access/User Table Properties
 
  For intProperty = tdfArch.Properties.Count To tdfLive.Properties.Count - 1
 
    Set prpLive = tdfLive.Properties(intProperty)
    Set prpArch = tdfArch.CreateProperty(prpLive.Name, prpLive.Type)
    prpArch.Value = prpLive.Value
    tdfArch.Properties.Append prpArch
 
  Next intProperty
 
  ' Copy Access/User Field Properties
 
  For intField = 0 To tdfArch.Fields.Count - 1
 
    Set fldLive = tdfLive.Fields(intField)
    Set fldArch = tdfArch.Fields(intField)
 
    For intProperty = fldArch.Properties.Count To fldLive.Properties.Count - 1
 
      Set prpLive = fldLive.Properties(intProperty)
      Set prpArch = fldArch.CreateProperty(prpLive.Name, prpLive.Type)
      prpArch.Value = prpLive.Value
      fldArch.Properties.Append prpArch
 
    Next intProperty
 
  Next intField
 
  ' Copy Access/User Index Properties
 
  For intIndex = 0 To tdfArch.Indexes.Count - 1
 
    Set idxLive = tdfLive.Indexes(tdfArch.Indexes(intIndex).Name)
 
    If Not idxLive.Foreign Then      ' don't copy foreign indexes - they're created by relationships
 
      Set idxArch = tdfArch.Indexes(intIndex)
 
      For intProperty = idxArch.Properties.Count To idxLive.Properties.Count - 1
 
        Set prpLive = idxLive.Properties(intProperty)
        Set prpArch = idxArch.CreateProperty(prpLive.Name, prpLive.Type)
        prpArch.Value = prpLive.Value
        idxArch.Properties.Append prpArch
 
      Next intProperty
 
    End If
 
  Next intIndex
 
  CopyTableDef = True
 
End Function

Now I can just create two Database objects and loop through the tables I want to copy over as follows :

Private Function CreateArchiveBE(lngYear) As String
 
  Dim wrk As Workspace
  Dim dbsLive As Database
  Dim dbsArch As Database
  Dim tdfLive As TableDef
  Dim objFSO As Object
  Dim arrArchiveTables() As String
  Dim strPath As String
  Dim i As Long
 
  arrArchiveTables = Split(strArchiveTables, ":")
 
  ' Define Path
 
  strPath = strArchiveFolder & "Archive" & lngYear & ".accdb"
 
  ' Confirm archive does not already exist (exit if found)
 
  Set objFSO = CreateObject("Scripting.FileSystemObject")
 
  If objFSO.FileExists(strPath) Then
    CreateArchiveBE = objFSO.GetFile(strPath).Path
    Exit Function
  End If
 
  ' Get default Workspace
 
  Set wrk = DBEngine.Workspaces(0)
 
  ' Create a new .accdb file
 
  Set dbsLive = wrk.OpenDatabase(strBackEndPath)
  Set dbsArch = wrk.CreateDatabase(strPath, dbLangGeneral)
 
  ' Loop through each table (using the TableDef object)
 
  For i = LBound(arrArchiveTables) To UBound(arrArchiveTables)
 
    Set tdfLive = dbsLive.TableDefs(arrArchiveTables(i))
 
    ' Copy from the live BE to the archive (structure only, no records)
 
    If Not CopyTableDef(tdfLive, dbsArch) Then
      MsgBox "Could not replicate BE", vbCritical, "Replication Error"
      Exit Function
    End If
 
  Next i
 
  CreateArchiveBE = strPath
 
  dbsLive.Close
  dbsArch.Close
 
  Set objFSO = Nothing
  Set tdfLive = Nothing
  Set dbsLive = Nothing
  Set dbsArch = Nothing
  Set wrk = Nothing
 
End Function

 

[JHB]

Good your got it "solved"!

 

[RainLover]

AOB

It is good to see code displayed in a correct manner. Or reasonably close.

What you are missing is some error trapping. I would assume that you will fix this latter. I would not normally say anything about this but you have started by using

On Error GoTo 0

 

[AOB]

Rain,

I usually omit the error handling from my posted code as everybody has a different way of dealing with them (errors). I have a general structure for all subs and functions though :

Function FunctionName(Argument As Type) As Type
 
  On Error GoTo ErrorHandler
  ...
 
Exit_FunctionName:
 
  ' Remove object handles i.e. Set obj = Nothing etc.
  Exit Function
 
ErrorHandler:
 
  Call LogError(Err.Number, Err.Description, "FunctionName", "ModuleName")
  Resume Exit_FunctionName
 
End Function

LogError is a public function which writes the error details to a table in the BE, so if any user hits an error, they aren't required to remember it - I can see it in the log.

However, in the case of the code which, let's be honest, I've basically stolen, the provider switches between On Error GoTo 0 and On Error Resume Next (neither of which I'm particularly keen on; however if you remove these, you will find that there are certain field / index properties which trigger an error, therefore this is needed to allow the code to run)

I could probably step through each one to identify specifically which properties to skip (thus preventing the error and using my own handling) but there are so many, and this seems to work anyway, that it seems to be a lot of effort for little or no gain?

Or reasonably close

If you have suggestions as to how my displayed code could be improved, I will always take advice?

 

[RainLover]

AOB

To give advise on your structure would take longer than the advantages it would yield.

I would suggest that you can only improve over time. However mine was not meant as a criticism. Far from it. I was saying that it was good to see some code with quality structure.

 

[AOB]

Ah, sorry, I mis-read you - thank you for the compliment! I thought you were suggesting I was posting the code incorrectly somehow, hence the confusion.

Hell, I know my structure could do with a tighten! But sure isn't that the fun of learning?

 

[RainLover]

Ah, sorry, I mis-read you - thank you for the compliment! I thought you were suggesting I was posting the code incorrectly somehow, hence the confusion.

Hell, I know my structure could do with a tighten! But sure isn't that the fun of learning?

Glad we got that sorted.

There are some who post garbage.

Your code structure is good.

 

[RainLover]

AOB

You might appreciate the attached.

It is a very good Error Handler that can be turned on and off when developing.

Feel free to use in a Professional manner