Private Sub cmdDAOCopy_Click()
Dim dbE As Object
Dim dbSrc As Object
Dim dbNew As Object
Dim tdefSrc As Object
Dim tdefNew As Object
Dim fdSrc As Object
Dim fdNew As Object
Dim ixSrc As Object
Dim ixNew As Object
Dim rsSrc As Object
Dim rsNew As Object
Dim rlSrc As Object
Dim rlNew As Object
Dim qdSrc As Object
Dim qdNew As Object
Dim prop As Object
Dim fAccess97 As Boolean
Dim strSource As String
Dim strDestination As String
Dim strPassword As String
Dim iCt As Integer
Dim iCount As Integer
Dim cTimer As clsTimer
Dim tl As Long
Dim t1 As Long, t2 As Long
'select database to copy
With cdlgFile
.DialogTitle = "Select Database to Copy"
.Filter = "Access 97/2000 (*.mdb)|*.mdb"
.CancelError = False
.InitDir = "C:\My Documents"
.ShowOpen
End With
strSource = cdlgFile.FileName
If strSource = "" Then
MsgBox "Cancel clicked"
Exit Sub
End If
strPassword = InputBox("Enter password for this database. Leave blank if no password required")
'open database with DAO 3.6 then find correct version
Set dbE = CreateObject("DAO.DBEngine.36")
Set dbSrc = dbE.OpenDatabase(strSource, False, False, ";pwd=" & strPassword)
On Error Resume Next
'loop through properties to find "Connect"
For Each prop In dbSrc.Properties
If prop.Name = "Version" Then
If prop.Value = "3.0" Then
fAccess97 = True
Else
fAccess97 = False
End If
Exit For
End If
Next prop
On Error GoTo 0
If fAccess97 Then
'Check if copy is to stay as Access 97 or convert to 2000
If MsgBox(strSource & vbCrLf & "Is an Access 97 Database. Do you want to convert it to Access 2000 Format?", vbQuestion + vbYesNo) = vbYes Then
fAccess97 = False
End If
End If
'Select name of database copy
With cdlgFile
.DialogTitle = "Save Database as"
.Filter = "Access 97/2000 (*.mdb)|*.mdb"
.CancelError = True
.InitDir = "C:\My Documents"
.ShowSave
End With
strDestination = cdlgFile.FileName
'check if chosen name already exists
If Dir$(strDestination) <> "" Then
If MsgBox(strDestination & " already exists. Overwrite?", vbQuestion + vbYesNo) = vbNo Then
Exit Sub
Else
Kill strDestination
End If
End If
'start timing...
Set cTimer = New clsTimer
cTimer.Reset
Me.Caption = "Creating database..."
DoEvents
If fAccess97 Then
'create 97 version
Set dbNew = dbE.CreateDatabase(strDestination, dbLangGeneral, dbVersion30)
Else
'create 2000 version
Set dbNew = dbE.CreateDatabase(strDestination, dbLangGeneral, dbVersion40)
End If
'now copy tables
For Each tdefSrc In dbSrc.TableDefs
'check if system table
If InStr(1, tdefSrc.Name, "MSys", vbTextCompare) = 0 Then
'not a system table
Set tdefNew = dbNew.CreateTableDef(tdefSrc.Name)
tdefNew.ValidationRule = tdefSrc.ValidationRule
tdefNew.ValidationText = tdefSrc.ValidationText
For Each fdSrc In tdefSrc.Fields
'check for replication fields s_GUID, s_Generation, s_Lineage, Gen_XXX
If InStr(1, fdSrc.Name, "s_", vbTextCompare) = 0 And InStr(1, fdSrc.Name, "Gen_", vbTextCompare) = 0 Then
Set fdNew = tdefNew.CreateField(fdSrc.Name, fdSrc.Type, fdSrc.Size)
On Error Resume Next
fdNew.Attributes = fdSrc.Attributes
fdNew.AllowZeroLength = fdSrc.AllowZeroLength
fdNew.DefaultValue = fdSrc.DefaultValue
fdNew.Required = fdSrc.Required
fdNew.Size = fdSrc.Size
tdefNew.Fields.Append fdNew
On Error GoTo 0
End If
Next
'now copy indexes
For Each ixSrc In tdefSrc.Indexes
'Check for replication indices s_GUID, s_Generation
If InStr(1, ixSrc.Name, "s_", vbTextCompare) = 0 Then
'Don't copy indices set as part of Relation Objects
If Not ixSrc.Foreign Then
Set ixNew = tdefNew.CreateIndex(ixSrc.Name)
ixNew.Clustered = ixSrc.Clustered
ixNew.IgnoreNulls = ixSrc.IgnoreNulls
ixNew.Primary = ixSrc.Primary
ixNew.Required = ixSrc.Required
ixNew.Unique = ixSrc.Unique
'Add Index field(s)
For Each fdSrc In ixSrc.Fields
Set fdNew = ixNew.CreateField(fdSrc.Name)
fdNew.Attributes = fdSrc.Attributes
ixNew.Fields.Append fdNew
Next
tdefNew.Indexes.Append ixNew
End If
End If
Next
dbNew.TableDefs.Append tdefNew
End If
Next
'now copy querydefs
For Each qdSrc In dbSrc.QueryDefs
Set qdNew = dbNew.CreateQueryDef(qdSrc.Name, qdSrc.SQL)
qdNew.Connect = qdSrc.Connect
qdNew.MaxRecords = qdSrc.MaxRecords
qdNew.ReturnsRecords = qdSrc.ReturnsRecords
'Next Line gives error 3219 Invalid operation, but is not needed as added automatically!
'Nice to have such consistency when dealing with objects!
'dbSrc.QueryDefs.Append qdNew
Next qdSrc
'now copy data
Me.Caption = "Copying Data..."
DoEvents
For Each tdefSrc In dbSrc.TableDefs
If InStr(1, tdefSrc.Name, "MSys", vbTextCompare) = 0 Then
'not a system table
Set rsNew = dbNew.OpenRecordset(tdefSrc.Name, dbOpenTable)
Set rsSrc = dbSrc.OpenRecordset(tdefSrc.Name, dbOpenTable)
If Not rsSrc.BOF Then
rsSrc.MoveFirst
Do Until rsSrc.EOF
rsNew.AddNew
For iCt = 0 To rsNew.Fields.Count - 1
rsNew.Fields(iCt).Value = rsSrc.Fields(rsNew.Fields(iCt).Name).Value
Next
rsNew.Update
rsSrc.MoveNext
Loop
End If
rsNew.Close
rsSrc.Close
End If
Next
'now copy relations
'Does not seem to be a similar method available with ADO...
For Each rlSrc In dbSrc.Relations
Set rlNew = dbNew.CreateRelation(rlSrc.Name, rlSrc.Table, rlSrc.ForeignTable, rlSrc.Attributes)
For Each fdSrc In rlSrc.Fields
rlNew.Fields.Append rlNew.CreateField(fdSrc.Name)
rlNew.Fields(fdSrc.Name).ForeignName = rlSrc.Fields(fdSrc.Name).ForeignName
Next fdSrc
dbNew.Relations.Append rlNew
Next rlSrc
dbNew.Close
dbSrc.Close
Set dbE = Nothing
tl = cTimer.Interval
Me.Caption = "Time taken " & tl & " ms(" & tl / 1000 & " secs, " & (tl / 1000) / 60 & " mins"
Set cTimer = Nothing
End Sub
Reply With Quote