|
VERSION 5.00
Begin VB.Form Form1
Caption = "DBEngine压缩数据库文件"
ClientHeight = 2205
ClientLeft = 60
ClientTop = 450
ClientWidth = 4680
LinkTopic = "Form1"
ScaleHeight = 2205
ScaleWidth = 4680
StartUpPosition = 3 'Windows Default
Begin VB.CheckBox chkBackup
Caption = "是否需要备份"
Height = 330
Left = 210
TabIndex = 3
Top = 735
Width = 2535
End
Begin VB.CommandButton cmdOK
Caption = "开始压缩"
Height = 435
Left = 1470
TabIndex = 2
Top = 1365
Width = 1695
End
Begin VB.TextBox txtSource
Height = 270
Left = 1680
TabIndex = 1
Top = 315
Width = 2850
End
Begin VB.Label Label1
Caption = "Access数据库："
Height = 330
Left = 210
TabIndex = 0
Top = 315
Width = 1380
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
'Access数据库实例
Option Explicit
Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
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压缩数据库文件
DBEngine.CompactDatabase Location, strTempFile
'删除原来的数据库文件
Kill Location
'拷贝刚刚压缩过临时数据库文件至原来位置
FileCopy strTempFile, Location
'删除临时文件
Kill strTempFilL
MsgBox "数据库压缩成功！", vbInformation, "完成"
Else
MsgBox "数据库文件不存在！", vbExclamation, "注意"
End If
Exit Sub
CompactErr:
MsgBox "压缩错误！" & vbCrLf & Err.Description, vbExclamation, "注意"
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
Private Sub cmdOK_Click()
If chkBackup.Value = 0 Then
Call CompactJetDatabase(txtSource.Text, False)
Else
Call CompactJetDatabase(txtSource.Text, True)
End If
End Sub [replyview]
[upload=rar]viewFile.asp?ID=29[/upload]
[/replyview] | 
