模块代码如下：
Option Explicit ' Public Declare Function GetTempPath Lib "kernel32" Alias _ "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Const MAX_PATH = 260
Public Sub CompactJetDatabase(Location As String, Optional BackupOriginal As Boolean = True)
' On Error GoTo CompactErr
Dim strBackupFile As String
Dim strTempFile As String
Dim DBEngine As jro.JetEngine
Set DBEngine = New jro.JetEngine
'检查数据库文件是否存在
If Dir(Location) <> "" Then
' 如果需要备份就执行备份
If BackupOriginal = True Then
strBackupFile = GetTemporaryPath & "backup.mdb"
If Dir(strBackupFile) <> "" Then Kill strBackupFile
FileCopy Location, strBackupFile
End If
' 创建临时文件名
strTempFile = GetTemporaryPath & "temp.mdb"
If Dir(strTempFile) <> "" Then Kill strTempFile
'通过DBEngine 压缩数据库文件
DBEngine.CompactDatabase Location, strTempFile
' 删除原来的数据库文件
Kill Location
' 拷贝刚刚压缩过临时数据库文件至原来位置
FileCopy strTempFile, Location
' 删除临时文件
Kill strTempFile
' Else
End If
'CompactErr:
' Exit Sub
End Sub
Public Function GetTemporaryPath()
Dim strFolder As String
Dim lngResult As Long
strFolder = String(MAX_PATH, 0)
lngResult = GetTempPath(MAX_PATH, strFolder)
If lngResult <> 0 Then
GetTemporaryPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
Else
GetTemporaryPath = ""
End If
End Function
[此贴子已经被作者于2004-05-01 15:03:50编辑过]
