|
При редактировании модулей БД разбухает. Не помню, где нашел код для перезаписи модулей, но пользуюсь периодически уже года три. После прогона БД и ее последующего сжатия размер уменьшается процентов на 25-30. Глюков не наблюдается. Те, кто опасаются, могут попробовать сначала на копии БД.
ClearModules 'имя модуля.
'Можно изменить, но тогда надо поменять и значение Const MyModuleName
Option Compare Text
Option Explicit
Public Function ClearMdl()
Dim MN As String, I As Integer, j As Integer, n As Integer
Dim mdl As Module, k As Long, S As String
Dim PathTempFile As String, ContainerName As String
Dim NN(10000) As String
Dim q As QueryDef, m As Long
'Эти константы можно изменять
'имя модуля с этой программой
Const MyModuleName As String = "ClearModules"
'имя временного запроса
Const QueryTempName As String = "_$Temp"
'имя временного файла
Const FileTempName As String = "~Module.txt"
'Будем размещать временный файл для перекачки модулей и 'запросов в своем каталоге
S = CurrentDb.Name
PathTempFile = left(S, Len(S) - Len(Dir(S))) + FileTempName
'Основной цикл по видам контейнеров
For I = 1 To 4
Select Case I
Case 1
ContainerName = "Forms"
Case 2
ContainerName = "Reports"
Case 3
ContainerName = "Modules"
Case 4
ContainerName = "QueryDefs"
End Select
SysCmd acSysCmdSetStatus, ContainerName
If I < 4 Then
n = CurrentDb.Containers(ContainerName).Documents.count - 1
For j = 0 To n
NN(j) = CurrentDb.Containers(ContainerName).Documents(j).Name
Next j
Else
n = CurrentDb.QueryDefs.count - 1
k = 0
For j = 0 To n
S = CurrentDb.QueryDefs(j).Name
If left(S, 1) <> "~" Then
NN(k) = S
k = k + 1
End If
Next j
n = k - 1
End If
If n >= 0 Then SysCmd acSysCmdInitMeter, ContainerName, (n + 1)
For j = 0 To n
MN = NN(j)
Select Case I
Case 1
DoCmd.OpenForm MN, acDesign, , , , acHidden
If Not Forms(MN).HasModule Then GoTo Nextj
Set mdl = Forms(MN).Module
Case 2
DoCmd.OpenReport MN, acDesign
If Not Reports(MN).HasModule Then GoTo Nextj
Set mdl = Reports(MN).Module
Case 3
If MN = MyModuleName Then GoTo Nextj
DoCmd.OpenModule MN
Set mdl = Modules(MN)
End Select
If Dir(PathTempFile) <> "" Then Kill PathTempFile
Open PathTempFile For Binary Access Write As #1
If I < 4 Then
For k = 1 To mdl.CountOfLines
S = mdl.Lines(k, 1) & Chr(13)
m = m + Len(S)
Put #1, , S
Next k
Else
On Error Resume Next
DoCmd.DeleteObject acQuery, QueryTempName
DoCmd.Rename QueryTempName, acQuery, MN
Set q = CurrentDb.QueryDefs(QueryTempName)
S = q.SQL
m = m + Len(S)
Put #1, , S
End If
Close #1
Select Case I
Case 1
Forms(MN).HasModule = False
DoCmd.Save acForm, MN
Forms(MN).HasModule = True
Set mdl = Forms(MN).Module
Case 2
Reports(MN).HasModule = False
DoCmd.Save acReport, MN
Reports(MN).HasModule = True
Set mdl = Reports(MN).Module
Case 3
If mdl.Type Then
DoCmd.RunCommand acCmdNewObjectClassModule
Else
DoCmd.RunCommand acCmdNewObjectModule
End If
S = Modules(Modules.count - 1).Name
DoCmd.Close acModule, MN
DoCmd.DeleteObject acModule, MN
DoCmd.Save acModule, S
DoCmd.Close acModule, S
DoCmd.Rename MN, acModule, S
DoCmd.OpenModule MN
Set mdl = Modules(MN)
End Select
If I < 4 Then
mdl.DeleteLines 1, mdl.CountOfLines
mdl.AddFromFile PathTempFile
Else
Open PathTempFile For Binary Access Read As #1
S = String(LOF(1), " ")
Get #1, , S
Close #1
On Error Resume Next
Err.Clear
Set q = CurrentDb.CreateQueryDef(MN, S)
If Err <> 0 Then
MsgBox "Ошибка в запросе " + MN + vbCrLf + "№ ошибки: " & Err & vbCrLf & Err.Description, vbInformation
DoCmd.Rename MN, acQuery, QueryTempName
End If
On Error GoTo 0
End If
Nextj:
Select Case I
Case 1: DoCmd.Close acForm, MN, acSaveYes
Case 2: DoCmd.Close acReport, MN, acSaveYes
Case 3: If MN <> MyModuleName Then DoCmd.Close acModule, MN, acSaveYes
End Select
SysCmd acSysCmdUpdateMeter, (j + 1)
Next j
Next I
On Error Resume Next
DoCmd.DeleteObject acQuery, QueryTempName
Kill PathTempFile
SysCmd acSysCmdClearStatus
MsgBox "Конец работы." + vbCrLf + " Переписано " & Format(m, "# ### ### ### ##0") & " байт.", vbInformation
End Function
Кому надо пользуйтесь
|
