Проще по-моему через SQL это сделать. Только лучше использовать ADO, через DAO, например, нельзя создать связь между таблицами с каскадным удалением. Пока это единственное ограничение DAO, с которым я встретился. Апдейчу бэкэнды исключительно SQL скриптами, очень удобно.
Под катом моя функция, которой пользуюсь для апдейта. Там есть вызовы других функций, напрямую не заработает, но идея будет понятна. В параметре - путь к файлу со скриптом.
'---------------------------------------------------------------------------------------
' Procedure : UpdateDatabase
' Purpose : Runs SQL script against common database. Returns True if success and false if errors were detected during execution
' Syntax:
' ";" at the end of each command
' "#" - comment, row ignored
' any SQL commands for db.Execute function, by default INSERT, UPDATE, DELETE executed in local DB
' SQL modifiers, word before SQL command:
' LOCAL - execute command in local db
' REMOTE - execute command in remote DB
' Additional commands:
' RUNMACRO <macro name>; - execute macro
' RUNCODE <function_name>; - copy "Update" module to remote DB and execute function <function_name>
' RUNCODEREMOTE <function_name>; - copy "Update" module to remote DB and execute function <function_name>
' RUNCODELOCAL <function_name>; - execute local function <function_name>
' DATAMACRO DISABLE|ENABLE; - disable or enable datamacro (runs SetDatamacroDisabled() function from common library)
'---------------------------------------------------------------------------------------
'
Public Function UpdateDatabase(strFileName As String) As Boolean
Dim strLine As String
Dim strSQL As String
Dim bolLineContinued As Boolean
Dim dbsRemote As Database
' Dim dbsLocal As Database
Dim errLoop As Error
Dim bolErr As Boolean
Dim bolResult As Boolean
Dim strDBFileName As String
Dim strMsg As String
Dim strFileVerFrom As String
Dim strFileVerTo As String
Dim strDBVersion As String
Dim strName As String
Dim oAccess As Access.Application
Dim strSqlToRelink As String
Dim strTblName As String
Dim tdfLocal As TableDef
Dim lErrNo As Long
Dim strErrDesc As String
Dim connLocal As ADODB.Connection
Dim connRemote As New ADODB.Connection
Dim bolModuleCopied As Boolean
Dim Msg As String
Dim intLen As Integer
Dim strCommand As String
On Error GoTo ErrorHandler
' Msg = "Highly recommended to make common database backup before update." & vbNewLine & "Do you want to make backup now?"
' If MsgBox(Msg, vbQuestion + vbYesNo, "Database Backup") = vbYes Then
' cmdBackupBE_Click
' End If
bolLineContinued = False
strSQL = ""
bolErr = False
bolResult = True
bolModuleCopied = False
Open strFileName For Input As #1
'Check format and version
Line Input #1, strLine
If Left(strLine, 20) = "# PPS DB Update Ver:" Then
strFileVerFrom = Mid(strLine, 19, Len(strLine) - InStr(19, strLine, " to ") - 3)
strFileVerTo = Mid(strLine, InStr(19, strLine, " to ") + 4)
strDBVersion = GetDefaultParam("VersionDBCommon", False)
If strDBVersion <> strFileVerFrom Then
If MsgBox("File version " & strFileVerTo & " requres database version " & strFileVerFrom & ", current database version " & strDBVersion & ". Do you want continue anyway?", vbExclamation + vbYesNo, "Versions mismatch") = vbNo Then
UpdateDatabase = False
Exit Function
End If
End If
ElseIf Left(strLine, 25) = "# CPE DB Data Import Ver:" Then
strFileVerFrom = Mid(strLine, 27, Len(strLine) - InStr(27, strLine, " to ") - 3)
strFileVerTo = Mid(strLine, InStr(24, strLine, " to ") + 4)
strDBVersion = GetDefaultParam("VersionDBCommon", False)
If strDBVersion <> strFileVerTo Then
If MsgBox("File version " & strFileVerTo & " requres database version " & strFileVerTo & ", current database version " & strDBVersion & ". Do you want continue anyway?", vbExclamation + vbYesNo, "Versions mismatch") = vbNo Then
UpdateDatabase = False
Exit Function
End If
End If
Else
MsgBox "File format not recognized, cannot update", vbExclamation, "Error"
UpdateDatabase = False
Exit Function
End If
strDBFileName = GetLinkedDBFileName()
Set dbsRemote = OpenDatabase(strDBFileName)
'Set dbsLocal = CurrentDb()
Set connLocal = CurrentProject.Connection
connRemote.Open "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDBFileName
Me.txtLog = ""
AppendText "Updating database: " & strDBFileName
AppendText "Used script file: " & strFileName
AppendText "Updating database from version " & strFileVerFrom & " to " & strFileVerTo
AppendText "Start time: " & Time() & vbNewLine
While Not EOF(1)
Line Input #1, strLine
strLine = Nz(Trim(strLine))
If InStr(strLine, "#") <> 1 Then
If (InStrRev(strLine, ";") = Len(strLine)) And (strLine <> "") Then
If bolLineContinued Then
strSQL = strSQL & " " & strLine
Else
strSQL = strLine
End If
strSqlToRelink = ""
strSQL = Trim(strSQL)
AppendText strSQL
DoCmd.Hourglass True
strCommand = Left(UCase(strSQL), InStr(strSQL, " ") - 1)
Select Case strCommand
Case "UPDATE", "INSERT", "DELETE"
'Can be used local table(s) for local database
Me.Painting = False
' 'refresh list of tables
' dbsRemote.Close
' Set dbsRemote = OpenDatabase(strDBFileName)
' dbsLocal.Close
' Set dbsLocal = CurrentDb()
On Error GoTo ErrorSQL
connLocal.Execute strSQL
'dbsLocal.Execute strSQL
On Error GoTo ErrorHandler
Me.Painting = True
Case "LOCAL"
'force local database
strSQL = Trim(Mid(strSQL, 7))
Me.Painting = False
On Error GoTo ErrorSQL
connLocal.Execute strSQL
On Error GoTo ErrorHandler
Me.Painting = True
Case "REMOTE"
'force remote database
strSQL = Trim(Mid(strSQL, 8))
Me.Painting = False
On Error GoTo ErrorSQL
connRemote.Execute strSQL
On Error GoTo ErrorHandler
Me.Painting = True
If InStr(1, UCase(strSQL), "CREATE TABLE") = 1 Then
strSqlToRelink = strSQL
End If
Case "RUNMACRO"
'Run specified macro
strName = Trim(Mid(strSQL, 10, Len(strSQL) - 10))
DoCmd.RunMacro strName
Case "RUNCODE", "RUNCODEREMOTE", "RUNCODELOCAL"
intLen = InStr(1, strSQL, " ") + 1
If intLen >= 9 Then
strName = Trim(Mid(strSQL, intLen, Len(strSQL) - intLen))
If Not bolModuleCopied And (strCommand = "RUNCODE" Or strCommand = "RUNCODEREMOTE") Then
'close ADO connection to prevent locking
connRemote.Close
DoCmd.SetWarnings False
DoCmd.CopyObject strDBFileName, , acModule, "Updates"
DoCmd.SetWarnings True
bolModuleCopied = True
connRemote.Open "Provider = Microsoft.ACE.OLEDB.12.0; data source=" & strDBFileName
End If
If strCommand = "RUNCODELOCAL" Then
On Error GoTo ErrorSQL
Eval strName
On Error GoTo ErrorHandler
Else
Set oAccess = CreateObject("Access.Application")
oAccess.OpenCurrentDatabase strDBFileName
On Error GoTo ErrorSQL
oAccess.Run strName
On Error GoTo ErrorHandler
oAccess.CloseCurrentDatabase
Set oAccess = Nothing
End If
End If
Case "DATAMACRO"
strName = UCase(Trim(Mid(strSQL, 11, Len(strSQL) - 11)))
If strName = "DISABLE" Then
SetDataMacroDisabled True
Else
SetDataMacroDisabled False
End If
Case Else
'Data Definition queries can be executed normally on remote DB only
Me.Painting = False
On Error GoTo ErrorSQL
connRemote.Execute strSQL
On Error GoTo ErrorHandler
Me.Painting = True
If InStr(1, UCase(strSQL), "CREATE TABLE") = 1 Then
strSqlToRelink = strSQL
End If
End Select
If strSqlToRelink <> "" Then
'try to relink created table
strTblName = GetNameFromSQL(strSQL, 13)
AppendText "Trying to re-link table " & strTblName & "..."
If IsRemoteTable(dbsRemote, strTblName) Then
'table exists in remote, reconnect or connect
If IsLinkedTableExists(strTblName) Then
'exists as local linked, reconnect
Set tdfLocal = CurrentDb.TableDefs(strTblName)
tdfLocal.Connect = ";Database=" & strDBFileName
tdfLocal.RefreshLink
AppendText "Table relinked"
Else
'table is new, link it
If CreateAttachedTable(strTblName, strDBFileName, strTblName) Then
AppendText "Linked new table"
Else
bolErr = True
AppendText "Error linking new table"
End If
End If
'refresh list of tables
dbsRemote.Close
Set dbsRemote = OpenDatabase(strDBFileName)
Else
AppendText "Table not found in remote database"
End If
End If
If Not bolErr Then
AppendText Time() & " - OK" & vbNewLine
Else
bolErr = False
End If
bolLineContinued = False
strSQL = ""
Else
bolLineContinued = True
strSQL = strSQL & " " & strLine
End If
Else
AppendText strLine
End If
Wend
ExitSQLError:
If bolResult Then
strMsg = "Update completed successfully."
SetDefaultParam "VersionDBCommon", strFileVerTo, False
Else
strMsg = "Update completed with errors."
End If
AppendText strMsg
UpdateDatabase = bolResult
ExitHere:
On Error Resume Next
DoCmd.Hourglass False
Me.Painting = True
Close 1
dbsRemote.Close
connLocal.Close
connRemote.Close
Set connLocal = Nothing
Set connRemote = Nothing
Set dbsRemote = Nothing
'enable datamacro in any case
SetDataMacroDisabled False
Exit Function
ErrorSQL:
DoCmd.Hourglass False
bolErr = True
bolResult = False
lErrNo = Err.Number
strErrDesc = Err.Description
AppendText vbNewLine & Time() & " - Error " & lErrNo & ": " & strErrDesc & vbNewLine
If MsgBox("Error SQL execution " & lErrNo & " (" & strErrDesc & ") in SQL:" & vbNewLine & _
strSQL & vbNewLine & "Continue update?", vbYesNo + vbExclamation + vbMsgBoxHelpButton, "Update error") = vbYes Then
Resume Next
Else
Resume ExitSQLError
End If
GoTo ExitHere
ErrorHandler:
DoCmd.Hourglass False
bolResult = True
Select Case Err
Case 0
Resume Next
Case 2501
MsgBox "2501!"
Resume ExitHere
Case Else
LogError Err.Number, Err.Description, Erl, "UpdateDatabase", "Form_frm_DatabaseMaintenance"
Resume ExitHere
End Select
End Function
