Option Compare Database

'.AddFromGuid "{AC3B8B4C-B6CA-11D1-9F31-00C04FC29D52}", 1, 0 ' Microsoft Jet and Replication Objects 2.6 Library 2

'============================================================

' Сжатие одного файла(диалог выбора)

'------------------------------------------------------------

Public Function CompressFile()

strPathCheck = CurrentProject.Path & "\"

Set DicFile = GetFile(strPathCheck)

If DicFile.Count > 0 Then

For Each el In DicFile.Keys

Debug.Print el

GetCompactReclaimedSpaceAmount False, el

Next el

End If

End Function

'============================================================

'============================================================

' Сжатие

'------------------------------------------------------------

Public Function GetCompactReclaimedSpaceAmount(ByVal bMsg As Boolean, ByVal 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

strNameFileNew = "D:\Public\Documents\Temp\": MkDir strNameFileNew

strNameFileNew = strNameFileNew & "\~" & 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 / 1048576 < 20 Then: Debug.Print "False": Exit Function

If bMsg Then

If lngValue = 0 Then MsgBox ("Сжатие не требуется."): Exit Function

End If

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 = strFileName & vbCrLf & _

"При сжатии будет высвобождено " & strMsg & Chr(13) & Chr(10) & "Будем сжимать?"

If bMsg Then

If (MsgBox(strMsg, vbYesNo) <> vbYes) Then Exit Function

End If

'======= Проверим, все ли отключились от базы

If ExistsConnectedUser(strFileName) Then

MsgBox "Не все пользователи отключились от базы." & _

vbCrLf & strFileName

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