本人新手，请指教！

Question

本人在做一个小项目，用VB6开发，数据库用的是Access2000。遇到一个很奇怪的问题，运行该工程，在Form的相应文本框和下拉框中填写数据点击“保存”按钮之后，打开数据库看到数据库表中只添加了一条记录，但是该数据库所占用的磁盘空间却比添加记录前大了几十倍！十分夸张，请问是何原因？有何解决办法？最好有源代码，谢谢！

Answer 1

是的，Access就是这样，使用中添加数据文件会自动扩大，但删除数据不会自动缩小。
使用DAO或ADOX开发，都有压缩Access数据库的方法。

Answer 2

压缩Access数据库我也知道，问题是每次利用ADO对数据库表操作一次，数据库就膨胀一次啊，软件是要给用户使用的啊，总不能要用户每添加一条记录，就去压缩一下数据库吧？我在想能不能调用某个API能在程序代码里面（也就是用户在使用该软件中，而不是使用该软件后）实现压缩数据库。

Answer 3

每次启动程序时压缩数据库！不会很慢的！
引用 dao3.6
定义一个DAO.DBEngine
Dim zip_db As New DAO.DBEngine
zip_db.CompactDatabase 要压缩的数据库名,压缩后的数据库名

Answer 4

谢谢大家，但是DBEngine.CompactDatabase方法怎么用啊？我要压缩的数据库和压缩后的数据库是同一个数据库啊。DBEngine.CompactDatabase方法该怎么写呢？我试了n种写法都不行，请指教，谢谢。

Answer 5

zip_db.CompactDatabase 要压缩的数据库名,压缩后的数据库名
filecopy  压缩后的数据库名,要压缩的数据库名
kill 压缩后的数据库名
注意压缩时先备份原数据库！！
明白？

Answer 6

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 　　'检查数据库文件是否存在 　　If Len(Dir(Location)) Then 　　 ' 如果需要备份就执行备份 　　 If BackupOriginal = True Then 　　 strBackupFile = GetTemporaryPath & "backup.mdb" 　　 If Len(Dir(strBackupFile)) Then Kill strBackupFile 　　 FileCopy Location, strBackupFile 　　 End If 　　 ' 创建临时文件名 　　 strTempFile = GetTemporaryPath & "temp.mdb" 　　 If Len(Dir(strTempFile)) Then Kill strTempFile 　　 '通过DBEngine 压缩数据库文件      Dim zip_db As New DAO.DBEngine　　 zip_db.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
----------------------------------------------------------------------------
请问是这样吗？但是zip_db.CompactDatabase Location, strTempFile 行报错啊
跳过去以后，后面的kill和filecopy也报错，不能用，是不是要引用什么啊？？

Answer 7

access2000 引用 microsoft dao 3.6 object library
access97 引用 microsoft dao 3.51 object library

Answer 8

引用 DAO3.6
定义一个DAO.DBEngine
Dim zip_db As New DAO.DBEngine
zip_db.CompactDatabase 要压缩的数据库名,压缩后的数据库名
filecopy  压缩后的数据库名,要压缩的数据库名
kill 压缩后的数据库名
已经备分原数据库！！运行时报错，请问filecopy和kill方法是不是用引用什么之后才能调用啊？？zip_db.CompactDatabase 方法应该怎么写啊？数据库名给出了完整正确的路径也报错是
怎么回事啊？

Answer 9

我用的是access2000 引用了 microsoft dao 3.6 object library
还是不行啊，ft

Answer 10

filecopy 和 kill 不用引用呀！！

Answer 11

用这个吧，需要引用“Microsoft Jet and Replication Objects 2.* Library”
'压缩数据库
Public Sub CompDatabase()
    On Error GoTo ErrMsg
    Dim jro As New jro.JetEngine
    Dim filePath As String, tempFilePath As String'filePath是原数据库文件路径，tempFilePath是临时的用于存放压缩后文件的路径
    Dim conStr1 As String, conStr2 As String
    
    If MsgBox("你确定要压缩当前的数据库吗？", vbQuestion + vbOKCancel, "小心！") = vbCancel Then
       Exit Sub
    End If
    
    GetCompactPath filePath, tempFilePath
    If UCase(Dir(tempFilePath)) = UCase("rsglTemp.mdb") Then
        Kill tempFilePath
    End If
    conStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filePath
    conStr2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & tempFilePath
    jro.CompactDatabase conStr1, conStr2
    Kill filePath
    Name tempFilePath As filePath'改回原来的名字
    MsgBox "数据库压缩成功", vbInformation + vbOKOnly, "祝贺"
    Exit Sub
ErrMsg:
    MsgBox "请确保其它应用程序没有使用当前数据库！" & vbCrLf & Err.Description & "然后关闭其它所有子窗体后再恢复！", vbInformation + vbOKOnly, "提示"
End Sub

Answer 12

用这个吧，需要引用“Microsoft Jet and Replication Objects 2.* Library”
'压缩数据库
Public Sub CompDatabase()
    On Error GoTo ErrMsg
    Dim jro As New jro.JetEngine
    Dim filePath As String, tempFilePath As String'filePath是原数据库文件路径，tempFilePath是临时的用于存放压缩后文件的路径
    Dim conStr1 As String, conStr2 As String
    
    If MsgBox("你确定要压缩当前的数据库吗？", vbQuestion + vbOKCancel, "小心！") = vbCancel Then
       Exit Sub
    End If
    
    GetCompactPath filePath, tempFilePath
    If UCase(Dir(tempFilePath)) = UCase("rsglTemp.mdb") Then
        Kill tempFilePath
    End If
    conStr1 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & filePath
    conStr2 = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & tempFilePath
    jro.CompactDatabase conStr1, conStr2
    Kill filePath
    Name tempFilePath As filePath'改回原来的名字
    MsgBox "数据库压缩成功", vbInformation + vbOKOnly, "祝贺"
    Exit Sub
ErrMsg:
    MsgBox "请确保其它应用程序没有使用当前数据库！" & vbCrLf & Err.Description & "然后关闭其它所有子窗体后再恢复！", vbInformation + vbOKOnly, "提示"
End Sub