ник: АлексейЕ
Программное сжатие mdb файла
Описание: Принцип работы кода:
- Запускается функция GetCompactReclaimedSpaceAmount с указанием в параметре имени и пути сжимаемого файла.
1. Проверяем существование файла и формируем имя для временного файла (используем Microsoft Windows Script Host (WSH))
2. Оценим размер высвобождаемого пространства (используем библиотеку ADO (Microsoft ActiveX Data Object))
3. Проверим, все ли отключились от базы (опять ADO)
4. Проведем сжатие базы в новый файл (Microsoft Jet OLE DB Provider и Replication Objects (JRO))
5. Производим замену старого файла на новый.
Использовал позднее связывание, так что должен работать без установленных ссылок на соответствующие библиотеки.
Public Function GetCompactReclaimedSpaceAmount(strFileName As String)
Const cstrConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
Dim strNameFileNew As String
Dim lngValue As Long
Dim strMsg As String
Dim JRO As Object
Dim File As Object
Dim cnn As Object
On Error Resume Next
'Проверям наличие файла для сжатия
Set File = CreateObject("Scripting.FileSystemObject").GetFile(strFileName)
If Err.Number <> 0 Then MsgBox "Файл не существует": Exit Function
'Формируем имя для временного файла
strNameFileNew = File.ParentFolder.Path & "\~" & File.Name
Set File = Nothing
'======= Оценим размер высвобождаемого пространства
Set cnn = CreateObject("ADODB.Connection")
cnn.Open cstrConnectionString & strFileName
lngValue = cnn.Properties("Jet OLEDB:Compact Reclaimed Space Amount").Value
cnn.Close: Set cnn = Nothing
If lngValue = 0 Then MsgBox ("Сжатие не требуется."): Exit Function
Select Case True
Case lngValue < 1024
strMsg = Format$(lngValue, "# ##0.00") & " байт"
Case lngValue < 1048576
strMsg = Format$(lngValue / 1024, "# ##0.00") & " кб."
Case Else
strMsg = Format$(lngValue / 1048576, "# ##0.00") & " мб."
End Select
strMsg = "При сжатии будет высвобождено " & strMsg & Chr(13) & Chr(10) & "Будем сжимать?"
If (MsgBox(strMsg, vbYesNo) <> vbYes) Then Exit Function
'======= Проверим, все ли отключились от базы
If ExistsConnectedUser(strFileName) Then
MsgBox "Не все пользователи отключились от базы."
Exit Function
End If
'====== Проведем сжатие базы в новый файл
'Удалим файл с именем временного файла
Set File = CreateObject("Scripting.FileSystemObject").GetFile(strNameFileNew)
If Err.Number = 0 Then
File.Delete
Set File = Nothing
Else
Err.Clear
End If
'Проведем сжатие
Set JRO = CreateObject("JRO.JetEngine")
JRO.CompactDatabase cstrConnectionString & strFileName, cstrConnectionString & strNameFileNew
'====== Заменим файлов.
If Not (ExistsConnectedUser(strFileName)) Then
Set File = CreateObject("Scripting.FileSystemObject").GetFile(strNameFileNew)
File.Copy strFileName, True
File.Delete
End If
End Function
'Функция проверяет имеются ли пользователи подключенные к базе
Public Function ExistsConnectedUser(strFileName As String) As Boolean
Dim cnn As Object 'As New ADODB.Connection
Dim rst As Object 'As ADODB.Recordset
Set cnn = CreateObject("ADODB.Connection")
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileName
Set rst = cnn.OpenSchema(-1, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
rst.MoveNext
ExistsConnectedUser = Not rst.EOF
rst.Close: Set rst = Nothing
cnn.Close: Set cnn = Nothing
End Function
|
Дополню немножко
Замечание - данный код тестировался и работает на Access 2003. На 2002 и 2000 не тестировался, но должен работать.
Для Access 2007 необходимо внести некоторые изменения.
1.
Const cstrConnectionString As String = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source="
|
заменить на
Const cstrConnectionString As String = " Provider=Microsoft.ACE.OLEDB.12.0;Data Source="
|
2.
JRO.CompactDatabase cstrConnectionString & strFileName, cstrConnectionString & strNameFileNew
|
заменить на
JRO.CompactDatabase _
cstrConnectionString & strFileName & ";Jet OLEDB:Engine Type=5", _
cstrConnectionString & strNameFileNew & ";Jet OLEDB:Engine Type=5"
|
(в принципе, Engine Type по умолчанию равем 5, и почему это не работае в 2007?... Не понятно.)
3.
cnn.Open "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & strFileName
|
заменить на
cnn.Open "Provider= Microsoft.ACE.OLEDB.12.0;Data Source=" & strFileName
|