Code:
Option Compare Database
Option Explicit
Dim appAccess As Access.Application, boLoadOK As Boolean
Private Function vcMakeAllInOne() As Boolean
Dim db As DAO.Database
Dim tdf As DAO.TableDef, qdf As DAO.QueryDef
Dim iCount As Integer, strFE_DB As String
Dim sFE_Name As String, sA1 As String, sA1FullName As String
Dim strMT_SQL As String, sTable As String, sTable_Local As String
Dim rstLetters As DAO.Recordset, strLetterName As String
Dim strAPP_SQL As String
'variable needed for indexes
Dim fld As DAO.Field, ind As DAO.Index, indPK As DAO.Index
Dim strIndexes As String, strIndex() As String, strPrimary As String, iIndex As Integer, tdfLocal As DAO.TableDef
Dim iOrdinalPosition As Integer, dbFuze As DAO.Database, strNonUniqueIndexes As String, strNonUniqueIndex() As String
Dim sA1Folder As String
On Error Resume Next
vcMakeAllInOne = False
strFE_DB = Nz(Me.FrontEndTemplate, "")
If strFE_DB = "" Then
MsgBox "Please select the database and try again!", vbCritical, "No Access file..."
Exit Function
End If
If (Right(Trim(strFE_DB), 3) <> "mdb" And Right(Trim(strFE_DB), 5) <> "accdb") Then
MsgBox "Please select a Microsoft Access database - mdb or accdb- and try again!", vbCritical, "No mdb or accdb file..."
Exit Function
End If
If Len(Dir(Trim(strFE_DB), 3)) = 0 Then
MsgBox "The file you selected does not exist!", vbCritical, "No mdb or accdb file..."
Exit Function
End If
sA1FullName = Nz(Me.AllInOneFullName, "")
sA1Folder = Left(sA1FullName, InStrRev(sA1FullName, "\"))
DoCmd.Hourglass True
Me.lblWorking.Visible = True
Me.Repaint
If Dir(sA1Folder, vbDirectory) = "" Then MyMkDir (sA1Folder)
'sFE_Name = Mid(strFE_DB, InStrRev(strFE_DB, "\") + 1)
If IsNull(Me.AllInOneFullName) Then
If Right(Trim(strFE_DB), 3) = "mdb" Then
sA1 = Left(strFE_DB, Len(strFE_DB) - 4) & "_A1.mdb"
Else
sA1 = Left(strFE_DB, Len(strFE_DB) - 6) & "_A1.accdb"
End If
Me.AllInOneFullName = sA1
Else
sA1 = sA1FullName
End If
Me.Dirty = False
Call CopyFile(strFE_DB, sA1)
Set dbFuze = CurrentDb
'lets export the hlpTables table to the all-in-one db
DoCmd.TransferDatabase acExport, "Microsoft Access", sA1, acTable, "hlpTables", "usysFUZE_Tables", True
'we need to replace the linked tables with local tables
Dim dbA1 As DAO.Database
Set appAccess = New Access.Application
appAccess.Visible = False
appAccess.OpenCurrentDatabase sA1
'repaint the form
Me.Requery
Me.Repaint
Me.lblWorking.Visible = True
appAccess.Echo False
appAccess.DoCmd.SetWarnings False
Dim intAutoCompact As Integer
intAutoCompact = appAccess.GetOption("Auto Compact")
'set compact on close
If Me.CompactOnClose = True Then appAccess.SetOption ("Auto Compact"), 1
appAccess.Visible = False
Me.Requery
Me.Repaint
'vcJan 26, 2010
Dim sLocalTable As String, sSourceTable As String, sDatabaseType As String, sConnect As String, sType As String, rstTables As DAO.Recordset
Set rstTables = appAccess.CurrentDb.OpenRecordset("usysFUZE_Tables", dbOpenDynaset)
DoCmd.SetWarnings False
For Each tdf In appAccess.CurrentDb.TableDefs
sLocalTable = tdf.Name
sSourceTable = tdf.SourceTableName
sConnect = tdf.Connect
If sConnect = "" Then
sType = "Local"
ElseIf InStr(sConnect, "Access") > 0 Or InStr(sConnect, "mdb") Or InStr(sConnect, "accdb") > 0 Then
sType = "Access"
ElseIf InStr(sConnect, "ODBC") > 0 Then
sType = "ODBC"
Else
sType = "Unknown"
End If
'write to hlpTables for de-fuzing
rstTables.AddNew
rstTables("LocalTable") = sLocalTable
rstTables("SourceTable") = sSourceTable
rstTables("ConnectionString") = sConnect
rstTables("TableType") = sType
rstTables.Update
'only do linked tables
If Len(tdf.Connect) > 0 Then
sTable = tdf.Name
sTable_Local = sTable & "_FBA_LOCAL"
strMT_SQL = "SELECT [" & sTable & "].* INTO [" & sTable_Local & "] FROM [" & sTable & "] Where True=False;" 'vc 15Oct2009
strAPP_SQL = "INSERT INTO [" & sTable_Local & "] SELECT [" & sTable & "].* FROM [" & sTable & "];" 'vc 15Oct2009
'get indexes
strIndexes = ""
strPrimary = ""
strNonUniqueIndexes = ""
For Each ind In tdf.Indexes
If ind.Unique = True Then
strIndexes = strIndexes & "|" & ind.Name
If ind.Primary = True Then
strPrimary = strPrimary & "|" & ind.Fields
End If
Else
strNonUniqueIndexes = strNonUniqueIndexes & "|" & ind.Name
End If
Next ind
'run the make-table query
appAccess.DoCmd.RunSQL strMT_SQL
Set dbA1 = appAccess.CurrentDb
Set tdfLocal = dbA1.TableDefs(sTable_Local)
On Error Resume Next
'set indexes
strPrimary = Replace(Replace(strPrimary, "|", ""), "+", "")
If strPrimary = "" Then GoTo vcSetIndexes
Dim sComposite() As String, iCountKey As Integer
sComposite() = Split(strPrimary, ";")
'drop column and add as autonumber
If InStr(tdf.Connect, "MySQL") > 1 Then 'MySQL
If tdfLocal.Fields(strPrimary).Type = dbLong Then 'if it is long integer assume is autonumber
'store ordinal position
iOrdinalPosition = tdfLocal.Fields(strPrimary).OrdinalPosition
appAccess.DoCmd.RunSQL ("ALTER TABLE [" & tdfLocal.Name & "] DROP COLUMN [" & strPrimary & "];")
Call fCreateAutoNumberField(sTable_Local, strPrimary, dbA1, iOrdinalPosition)
End If
tdfLocal.Fields.Refresh
ElseIf InStr(tdf.Connect, "Oracle") > 1 Then 'Oracle 'vc20140331
If tdfLocal.Fields(strPrimary).Type = dbDecimal Then 'if it is decimal assume is autonumber
'store ordinal position
iOrdinalPosition = tdfLocal.Fields(strPrimary).OrdinalPosition
appAccess.DoCmd.RunSQL ("ALTER TABLE [" & tdfLocal.Name & "] DROP COLUMN [" & strPrimary & "];")
Call fCreateAutoNumberField(sTable_Local, strPrimary, dbA1, iOrdinalPosition)
End If
tdfLocal.Fields.Refresh
End If
'set primary key
Set ind = tdfLocal.CreateIndex("PrimaryKey")
With ind
For iCountKey = 0 To UBound(sComposite)
.Fields.Append .CreateField(sComposite(iCountKey))
.Unique = True
.Primary = True
Next
End With
tdfLocal.Indexes.Append ind
tdfLocal.Indexes.Refresh
vcSetIndexes:
'now the rest of the indexes
'first the unique ones
strIndex = Split(strIndexes, "|")
For iIndex = 0 To UBound(strIndex)
If strIndex(iIndex) <> "" Then
Set ind = tdfLocal.CreateIndex(strIndex(iIndex))
With ind
.Fields.Append .CreateField(strIndex(iIndex))
.Unique = True
End With
tdfLocal.Indexes.Append ind
tdfLocal.Indexes.Refresh
End If
Next
'now the non-unique
strNonUniqueIndex = Split(strNonUniqueIndexes, "|")
For iIndex = 0 To UBound(strNonUniqueIndex)
If strNonUniqueIndex(iIndex) <> "" Then
Set ind = tdfLocal.CreateIndex(strNonUniqueIndex(iIndex))
With ind
.Fields.Append .CreateField(strNonUniqueIndex(iIndex))
.Unique = False
End With
tdfLocal.Indexes.Append ind
tdfLocal.Indexes.Refresh
End If
Next
'lets add the data
appAccess.DoCmd.RunSQL strAPP_SQL 'vc 15Oct2009
appAccess.DoCmd.DeleteObject acTable, sTable
End If
Next tdf
Set dbA1 = appAccess.CurrentDb
For Each tdf In dbA1.TableDefs
If Right(tdf.Name, 10) = "_FBA_LOCAL" Then
tdf.Name = Left(tdf.Name, Len(tdf.Name) - 10)
End If
Next tdf
SetApplicationTitle (appAccess.CurrentDb.Properties("AppTitle") & " <<ALL-IN-ONE>>")
appAccess.RefreshTitleBar
appAccess.DoCmd.SetWarnings True
appAccess.Echo True
If Me.LeaveFileOpen = False Then
appAccess.Quit acQuitSaveAll
Else
appAccess.Visible = True
End If
On Error Resume Next
'lets copy additional files
vcCopyAdditionalFiles
EXIT_vcMakeAllInOne:
DoCmd.Hourglass False
vcMakeAllInOne = True
Application.Quit
End Function
You can see in the example above how I open a new instance of Access, open a new file (in your case that would be one of your sites) and process it to my needs.