- MyDocを使用してAccessのオブジェクト（テーブル、クエリ、フォーム、レポート、マクロ、モジュール）の修正履歴の一覧をリストアップします。最終更新日の範囲を指定するとバージョンアップするための一覧をリストアップできます。
 |
| 図１-MyDocでバージョンアップする一覧をリストアップする |
- MyDocの一覧リストをもとにバージョンアップ用の差分ファイル（Update.mdb)を作成します。
- アプリのメインメニューにバージョンアップ用のコマンドボタン（ｃｍｄVersionUp)を作成して、クリック時のイベントからAutoUpgrade_FS()関数を呼び出します。このとき、引数として差分データベースのフルパス名を指定します。
| リスト１-コマンドボタンのクリック時のイベント処理 |
Private Sub cmdVersionUp_Click()
If AutoUpgrade_FS("C:\Access\Update.mdb") Then
MsgBox "Upgraded Successfully!"
Else
MsgBox "Upgrade Failed!"
End If
End Sub |
- 参考までに、AutoUpgrade_FS()関数のソースコードを添付しますので自由にカスタマイズしてください。この例では、関数の引数を定義するときAccess 2000でサポートされたenumを使用しています。Access
97で使用するときは、enumの指定を削除してください。
Access 2000用
Private Function SelObjects(strDatabase As String, _
lngObjectType As AcObjectType) _
As Variant |
Private
Function IsSystemObject(lngObjectType As AcObjectType,
_
ByVal strName As String, _
Optional ByVal varAttribs As Variant) _
As Boolean
|
Private
Function IsOpen_FS(strName As String, _
Optional lngObjectType As AcObjectType = acForm)
_
As Boolean
|
Access 97用
Private Function
SelObjects(strDatabase As String, _
lngObjectType As Long) _
As Variant
|
Private
Function IsSystemObject(lngObjectType
As Long, _
ByVal strName As String, _
Optional ByVal varAttribs As Variant) _
As Boolean
|
Private
Function IsOpen_FS(strName As String, _
Optional lngObjectType As Long = acForm) _
As Boolean
|
| リスト２-AutoUpgeade_FS() |
Option Compare Database
Option Explicit
' **************************************************************
Public Function AutoUpgrade_FS(strDatabase As String) As Boolean
Dim avarObjects As Variant ' 1-based index
Dim strName As String
Dim intI As Integer
If Len(Trim(Dir(strDatabase))) = 0 Then
MsgBox "差分ﾌｧｲﾙ <" & strDatabase & "> が見つかりません！", vbCritical
AutoUpgrade_FS = False
Exit Function
End If
DoCmd.SetWarnings False
On Error Resume Next
' Update tables
avarObjects = SelTables(strDatabase)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
DoCmd.DeleteObject acTable, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acTable, strName, strName
' Debug.Print "Updated table", strName
Next intI
End If
' Update queries
avarObjects = SelQueries(strDatabase)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
DoCmd.DeleteObject acQuery, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acQuery, strName, strName
' Debug.Print "Updated query", strName
Next intI
End If
' Update forms
avarObjects = SelObjects(strDatabase, acForm)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
If IsOpen_FS(strName, acForm) Then
DoCmd.Close acForm, strName
End If
DoCmd.DeleteObject acForm, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acForm, strName, strName
' Debug.Print "Updated form", strName
Next intI
End If
' Update reports
avarObjects = SelObjects(strDatabase, acReport)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
If IsOpen_FS(strName, acReport) Then
DoCmd.Close acReport, strName
End If
DoCmd.DeleteObject acReport, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acReport, strName, strName
' Debug.Print "Updated report", strName
Next intI
End If
' Update macros
avarObjects = SelObjects(strDatabase, acMacro)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
DoCmd.DeleteObject acMacro, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acMacro, strName, strName
' Debug.Print "Updated macro", strName
Next intI
End If
' Update modules
avarObjects = SelObjects(strDatabase, acModule)
If UBound(avarObjects) > 0 Then
For intI = 1 To UBound(avarObjects)
strName = avarObjects(intI)
DoCmd.DeleteObject acModule, strName
DoCmd.TransferDatabase acImport, "Microsoft Access", _
strDatabase, acModule, strName, strName
' Debug.Print "Updated module", strName
Next intI
End If
DoCmd.SetWarnings True
' Compact/Repair MDB
SendKeys "%(TDC)"
AutoUpgrade_FS = True
End Function
' ***********************************************
Private Function SelTables(strDatabase As String) _
As Variant
Dim db As DAO.Database
Dim tdf As DAO.TableDef
Dim fSystemObj As Boolean
Dim avarObjects() As Variant ' 1-based index
Dim intI As Integer
If Len(Trim(strDatabase)) = 0 Then
Set db = CurrentDb
Else
Set db = DBEngine.Workspaces(0).OpenDatabase(strDatabase)
End If
With db
.TableDefs.Refresh
If .TableDefs.Count > 0 Then
ReDim avarObjects(1 To .TableDefs.Count) ' Include System Tables
For Each tdf In .TableDefs
With tdf
fSystemObj = IsSystemObject(acTable, .Name, .Attributes)
If Not fSystemObj And ((.Attributes And dbHiddenObject) = 0) Then
intI = intI + 1
avarObjects(intI) = .Name
End If
End With
Next tdf
End If
If intI = 0 Then
ReDim avarObjects(0)
Else
ReDim Preserve avarObjects(1 To intI)
End If
End With
SelTables = avarObjects
End Function
' ************************************************
Private Function SelQueries(strDatabase As String) _
As Variant
Dim db As DAO.Database
Dim qdf As DAO.QueryDef
Dim fSystemObj As Boolean
Dim avarObjects() As Variant ' 1-based index
Dim intI As Integer
If Len(Trim(strDatabase)) = 0 Then
Set db = CurrentDb
Else
Set db = DBEngine.Workspaces(0).OpenDatabase(strDatabase)
End If
With db
.QueryDefs.Refresh
If .QueryDefs.Count > 0 Then
ReDim avarObjects(1 To .QueryDefs.Count) ' Include System Tables
For Each qdf In .QueryDefs
With qdf
fSystemObj = IsSystemObject(acQuery, .Name)
If Not fSystemObj Then
intI = intI + 1
avarObjects(intI) = .Name
End If
End With
Next qdf
End If
If intI = 0 Then
ReDim avarObjects(0)
Else
ReDim Preserve avarObjects(1 To intI)
End If
End With
SelQueries = avarObjects
End Function
' ************************************************
Private Function SelObjects(strDatabase As String, _
lngObjectType As AcObjectType) _
As Variant
Dim db As DAO.Database
Dim ctr As DAO.Container
Dim doc As DAO.Document
Dim strName As String
Dim fSystemObj As Boolean
Dim avarObjects() As Variant ' 1-based index
Dim intI As Integer
If Len(Trim(strDatabase)) = 0 Then
Set db = CurrentDb
Else
Set db = DBEngine.Workspaces(0).OpenDatabase(strDatabase)
End If
With db
Select Case lngObjectType
Case acForm
Set ctr = .Containers("Forms")
Case acReport
Set ctr = .Containers("Reports")
Case acMacro
Set ctr = .Containers("Scripts")
Case acModule
Set ctr = .Containers("Modules")
End Select
End With
With ctr
.Documents.Refresh
If .Documents.Count > 0 Then
ReDim avarObjects(1 To .Documents.Count) ' Include System Tables
For Each doc In .Documents
strName = doc.Name
fSystemObj = IsSystemObject(lngObjectType, strName)
If Not fSystemObj And Not IsDeleted(strName) Then
intI = intI + 1
avarObjects(intI) = strName
End If
Next doc
End If
If intI = 0 Then
ReDim avarObjects(0)
Else
ReDim Preserve avarObjects(1 To intI)
End If
End With
SelObjects = avarObjects
End Function
' *************************************************
Private Function IsDeleted(ByVal strName As String) _
As Boolean
IsDeleted = (Left(strName, 7) = "~TMPCLP")
End Function
' ************************************************************
Private Function IsSystemObject(lngObjectType As AcObjectType, _
ByVal strName As String, _
Optional ByVal varAttribs As Variant) _
As Boolean
If IsMissing(varAttribs) Then
varAttribs = 0
End If
If (Left(strName, 4) = "USys") Or Left(strName, 4) = "~sq_" Then
IsSystemObject = True
Else
IsSystemObject = ((lngObjectType = acTable) _
And ((varAttribs And dbSystemObject) <> 0))
End If
End Function
' ******************************************
Private Function IsOpen_FS(strName As String, _
Optional lngObjectType As AcObjectType = acForm) _
As Boolean
IsOpen_FS = (SysCmd(acSysCmdGetObjectState, lngObjectType, strName) <> 0)
End Function
|
|