Это измененный вариант даннойго модуля с использованием ADO.
' Module : ClearModules
' DateTime : 16.01.2008 00:42
' Release : 1.2
' Author : Юрий Шерман, доработан под ADO Дмитрием Сонных (aka Joss)
' Purpose : Очистка модулей и запросов от мусора.
'----------------------------------------------------------------------
Option Compare Database
Option Explicit
' Комментарий: при корректировке модулей A-97, A-2000
' оставляет мусор,
' который не устраняется стандартными способами
' (Compact, Import).
'
'ПОРЯДОК ИСПОЛЬЗОВАНИЯ ПРОГРАММЫ
'0. Сделайте на всякий случай копию базы.
'1. Включите модуль ClearModules в состав модулей Вашей
'базы.
'2. Запустите программу ClearMdl, например, из отладчика
'или с помощью F5, предварительно установив курсор на
'исполняемый текст программы.
'3. Сожмите базу данных после окончания работы программы,
'и Вы будете приятно удивлены новым размером Вашей базы.
Public Function ClearMdl()
Dim mdl As Module, arrNames() As String, strName As String
Dim PathTempFile As String, ContainerName As String
Dim i As Long, j As Long, k As Long, m As Long, n As Long
Dim S As String
'Эти константы можно изменять
'имя модуля с этой программой
Const MyModuleName As String = "ClearModules"
'имя временного файла для переписи тектов модулей
Const FileTempName As String = "~Module.txt"
'Разместим временный файл для перекачки модулей в своем каталоге
S = CurrentProject.FullName
PathTempFile = Left(S, Len(S) - Len(Dir(S))) + FileTempName
On Error GoTo ErrClear
'Основной цикл по видам контейнеров
For i = 1 To 3
Select Case i
Case 1
ContainerName = "Forms"
n = CurrentProject.AllForms.Count - 1
Case 2
ContainerName = "Reports"
n = CurrentProject.AllReports.Count - 1
Case 3
ContainerName = "Modules"
n = CurrentProject.AllModules.Count - 1
End Select
If n < 0 Then GoTo Nexti
'Запоминаем список документов
ReDim arrNames(n)
For j = 0 To n
Select Case i
Case 1
arrNames(j) = CurrentProject.AllForms(j).Name
Case 2
arrNames(j) = CurrentProject.AllReports(j).Name
Case 3
arrNames(j) = CurrentProject.AllModules(j).Name
End Select
Next j
SysCmd acSysCmdInitMeter, ContainerName, (n + 1)
'Цикл по документам
For j = 0 To n
'Открываем модуль, если он есть
strName = arrNames(j)
Select Case i
Case 1
DoCmd.OpenForm strName, acDesign, , , , acHidden
If Not Forms(strName).HasModule Then GoTo Nextj
Set mdl = Forms(strName).Module
Case 2
DoCmd.OpenReport strName, acDesign
If Not Reports(strName).HasModule Then GoTo Nextj
Set mdl = Reports(strName).Module
Case 3
If strName = MyModuleName Then GoTo Nextj
DoCmd.OpenModule strName
Set mdl = Modules(strName)
End Select
'Переписываем модуль в текстовый файл
If Dir(PathTempFile) <> "" Then Kill PathTempFile
Open PathTempFile For Binary Access Write As #1
For k = 1 To mdl.CountOfLines
S = mdl.Lines(k, 1) & Chr(13)
m = m + Len(S) 'счетчик переписанных байтов
Put #1, , S
Next k
Close #1
'Удаляем старый модуль и создаем пустой новый
Select Case i
Case 1
Forms(strName).HasModule = False
DoCmd.Save acForm, strName
Forms(strName).HasModule = True
Set mdl = Forms(strName).Module
Case 2
Reports(strName).HasModule = False
DoCmd.Save acReport, strName
Reports(strName).HasModule = True
Set mdl = Reports(strName).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, strName
DoCmd.DeleteObject acModule, strName
DoCmd.Save acModule, S
DoCmd.Close acModule, S
DoCmd.Rename strName, acModule, S
DoCmd.OpenModule strName
Set mdl = Modules(strName)
End Select
'Удаляем в новом модуле стандартные строки
mdl.DeleteLines 1, mdl.CountOfLines
'Загружаем текст модуля из файла
mdl.AddFromFile PathTempFile
Nextj:
'Записываем обновленный модуль в базу
Select Case i
Case 1: DoCmd.Close acForm, strName, acSaveYes
Case 2: DoCmd.Close acReport, strName, acSaveYes
Case 3: If strName <> MyModuleName Then DoCmd.Close acModule, strName, acSaveYes
End Select
SysCmd acSysCmdUpdateMeter, (j + 1)
Next j
Nexti:
Next i
If Dir(PathTempFile) <> "" Then Kill PathTempFile
SysCmd acSysCmdClearStatus
MsgBox "Конец работы." + vbCrLf + " Переписано " & _
Format(m, "# ### ### ### ##0") & " байт.", vbInformation
Exit Function
ErrClear:
MsgBox "Ошибка при обработке: ContainerName= " & ContainerName & _
", DocumentName= " & strName & Chr(13) & _
"№ ошибки= " & Err & ". " & Err.Description
Stop
Resume
End Function
'--------------------------------------------------------------------------------
'Конец текста модуля
Просмотров: 11907
 Коментарии (9) |
 |
| Добавить коментарий |