模块代码如下：

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编辑过]

然后我在窗体中调用CompactJetDatabase()

代码是这样的：Call CompactJetDatabase("D:\vcd.mdb",Ture)

运行时错误提示为：初始化字符串不符合OLE　ＤＢ规定

这个方法对我是没有用的，它的压缩比不高。

它只是重新再生成另个一个表，不可覆盖原表。

你们能不能把我那方法修一下啊，那个是不错的。