MDBをコンパクトにするVBA

Option Compare Database

' 一時ファイル名取得用 API の宣言
Declare Function GetTempFileName Lib "kernel32" Alias "GetTempFileNameA" _
   (ByVal lpszPath As String, ByVal lpPrefixString As String, _
   ByVal wUnique As Long, ByVal lpTempFileName As String) As Long


' 一時ファイル名の取得
Public Function udGetTempFileName(argPath) As String
Dim lngRet As Long
Dim strFileName As String * 255

lngRet = GetTempFileName(argPath, "acc", 0&, strFileName)

udGetTempFileName = Left(strFileName, InStr(strFileName, vbNullChar) - 1)
End Function
' フルパス名からディレクトリ名(フォルダ名)の取得
Public Function udGetFolderName(argPath) As String
Dim lngPos As Long
For lngPos = Len(argPath) To 1 Step -1
   If Mid(argPath, lngPos, 1) = "\" Then
       udGetFolderName = Left(argPath, lngPos)
       Exit Function
   End If
Next
End Function

bas

Option Compare Database
Option Explicit

Private Sub Form_Timer()
   Dim strSrcDB As String
   Dim strDstDB As String
   Dim lngRet As Long
   
   On Error GoTo Form_Timer_Err
   
   strSrcDB = CurrentProject.Path & "\snapSchema.mdb"
   
   If strSrcDB = "" Then ' この mdb を直接開いた場合の判断
       Me.TimerInterval = 0
       DoCmd.Close
       Exit Sub
   End If
   
   strDstDB = udGetTempFileName(udGetFolderName(strSrcDB))
   ' Windows API GetTempFileName はファイルを作成するため削除
   Kill strDstDB
   DoEvents ' 念のため入れてあります
   DBEngine.CompactDatabase strSrcDB, strDstDB
   Kill strSrcDB ' 最適化前の mdb ファイルの保存が必要であれば、Name で変更
   Name strDstDB As strSrcDB
   '【注1】 元の mdb ファイルを開きなおす場合
   ' DoEvents
   ' lngRet = Shell(strSrcDB)
   DoCmd.Quit
   Exit Sub
   
Form_Timer_Err:
   If Err.Number = 3054 Or Err.Number = 3356 Then ' 【注2】再実行するエラーコード
       If MsgBox(strSrcDB & " は使用中です。" & vbCrLf & vbCrLf & _
           "最適化を中止しますか?", vbExclamation + vbYesNo) = vbYes Then
           DoCmd.Quit
       End If
   Else
       MsgBox "実行時エラー '" & Err.Number & "':" & vbCrLf & vbCrLf & _
           Err.Description, vbCritical
   End If
   Exit Sub

End Sub
トップ   編集 凍結 差分 バックアップ 添付 複製 名前変更 リロード   新規 一覧 単語検索 最終更新   ヘルプ   最終更新のRSS
Last-modified: 2010-09-09 (木) 12:31:28 (4060d)