MDBをコンパクトにするVBA
をテンプレートにして作成
[
トップ
] [
新規
|
一覧
|
単語検索
|
最終更新
|
ヘルプ
]
開始行:
*MDBをコンパクトにするVBA [#ie66de9f]
Option Compare Database
' 一時ファイル名取得用 API の宣言
Declare Function GetTempFileName Lib "kernel32" Alias "G...
(ByVal lpszPath As String, ByVal lpPrefixString As St...
ByVal wUnique As Long, ByVal lpTempFileName As String...
' 一時ファイル名の取得
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,...
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 [#m2feb9e2]
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 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 ' 【注...
If MsgBox(strSrcDB & " は使用中です。" & vbCrLf &...
"最適化を中止しますか?", vbExclamation + vbY...
DoCmd.Quit
End If
Else
MsgBox "実行時エラー '" & Err.Number & "':" & vbC...
Err.Description, vbCritical
End If
Exit Sub
End Sub
終了行:
*MDBをコンパクトにするVBA [#ie66de9f]
Option Compare Database
' 一時ファイル名取得用 API の宣言
Declare Function GetTempFileName Lib "kernel32" Alias "G...
(ByVal lpszPath As String, ByVal lpPrefixString As St...
ByVal wUnique As Long, ByVal lpTempFileName As String...
' 一時ファイル名の取得
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,...
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 [#m2feb9e2]
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 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 ' 【注...
If MsgBox(strSrcDB & " は使用中です。" & vbCrLf &...
"最適化を中止しますか?", vbExclamation + vbY...
DoCmd.Quit
End If
Else
MsgBox "実行時エラー '" & Err.Number & "':" & vbC...
Err.Description, vbCritical
End If
Exit Sub
End Sub
ページ名: