Модуль для очистки проектов ACCESS от мусора (ADO) |
Автор Дмитрий Сонных (aka Joss) | |||||||||||||||
27.01.2008 г. | |||||||||||||||
Модуль Юрия Шермана для очистки от мусора и исправления других модулей , не работает в ADP т.к. использует DAO. Это измененный вариант даннойго модуля с использованием 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 '-------------------------------------------------------------------------------- 'Конец текста модуля Просмотров: 11896
|