Option Compare Database

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

Sub FF()

Dim oDb As Object

Dim Pr As Object, Pr2 As Object

Dim i As Integer: i = 1

Dim j As Integer:

'Dim strName As String

'Dim vValue As Variant

On Error Resume Next

Set oDb = CurrentDb

For Each Pr In oDb.Properties

Debug.Print i & " ================================================================"

Debug.Print " " & Pr.Name & " - " & Pr.Value

j = 1

For Each Pr2 In Pr.Properties

Debug.Print " " & j & " " & Pr2.Name & " - " & Pr2.Value

j = j + 1

Next 'Pr2

i = i + 1

If i = 16 Then Stop

If i = 31 Then Stop

If i = 46 Then Stop

Next Pr

Set oDb = Nothing

End Sub

Public Function GetCompactReclaimedSpaceAmount(ByVal bMsg As Boolean, ByVal strFileName As String)

Const cstrConnectionString As String = "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" '"Provider=Microsoft.Jet.OLEDB.4.0;Data Source="

'"Provider=Microsoft.Jet.OLEDB.4.0;Data Source=databaseName;User ID=userName;Password=userPassword;"

'"Provider=Microsoft.ACE.OLEDB.12.0;Data Source=C:\myFolder\myAccessFile.accdb;Persist Security Info=False;"

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

Stop

For Each Pr In cnn.Properties

Debug.Print Pr.Name & " - " & Pr.Value

Next

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