Один из вариантов регламентного дублирования базы данных (с использованием архиватора WinRAR)
PROCEDURE DublBD
* ПРОЦЕДУРА ДУБЛИРОВАНИЯ БД
SELECT 0
USE DatesDubl.dbf &&открываем таблицу с историей дублирования
GO BOTTOM
IF Date() > DatesDubl.dLastDubl + 14 THEN && время дублирования наступило?
IF MESSAGEBOX("Наступило время обязательного дублирования базы
данных."+CHR(10)+;
"Без дублирования работать дальше Вы не сможете."+CHR(10)+;
"Начать дублирование сейчас?.",;
4+64+0,"ИНФОРМАЦИЯ") = 6 THEN
* делаем подготовку (определяем пути, собираем файлы и пр.)
LOCAL lcListFilds && список дублируемых файлов
lcListFilds = DataPath + "*.d?? ";
+ DataPath + "*.cdx ";
+ DataPath + "*.f?? ";
+ DataPath + "*.tbk ";
+ DataPath + "*.old"
LOCAL lcPathTarget && путь назначения
LOCAL Y, M, D
* генерируем имя файла
Y = ALLTRIM(STR(YEAR(DATE()))) && год
M = ALLTRIM(STR(MONTH(DATE()))) && месяц
IF LEN(M)<2 THEN && если месяц 1 цифра - добавляем слева ноль
M="0"+M
ENDIF
D = ALLTRIM(STR(DAY(DATE()))) && день
IF LEN(D)<2 THEN && если день 1 цифра - добавляем слева ноль
D="0"+D
ENDIF
lcPathTarget = ""
* проверим на предмет задания папки
DO WHILE EMPTY(ALLTRIM(lcPathTarget))
lcPathTarget = "DublKlassNar_"+Y+"_"+M+"_"+D && генерируем имя файла
lcPathTarget = PUTFILE("Имя файла-дубля",lcPathTarget,"rar") &&
определяем путь и имя файла для записи
IF EMPTY(ALLTRIM(lcPathTarget )) THEN
IF MESSAGEBOX ("Не указана папка, куда складывать дубли."+CHR(10)+;
"Повторить поиск папки?",4+32+0,"ВОПРОС") # 6;
THEN
DO MyExit && уходим
ENDIF
ENDIF
ENDDO
LOCAL lcArgument && пути,. имена файлов, команды и ключи для архиватора WinRar
lcArgument = " a -m5 " + lcPathTarget + " " + lcListFilds
* АРХИВИРУЕМ
*объявляем функцию api для отлавливания начала и завершения дублирования
DECLARE integer FindWindow IN Win32API string, string
LOCAL StartDateTime && время начала старта
LOCAL lcMessError && сообщение об ошибке
* Проверяем на предмет незанятости базы данных
LOCAL lcOldError
lcOldError = ON('Error') && запоминаем путь к старому обработчику ошибок
ON ERROR DO Zaglushka
LOCAL llZanjato
llZanjato = .T.
DO WHILE llZanjato && крутимся в цикле, пока не освободится БД
OPEN DATABASE KlassNar EXCLUSIVE
IF DBUSED('KlassNar') THEN && если база открылась, то работаем
llZanjato = .F.
ELSE
IF MESSAGEBOX("Кто-то работает с базой данных."+CHR(10)+;
"Дублировать базу данных невозможно."+CHR(10)+;
"Выгоните их всех!"+CHR(10)+CHR(10)+;
"Повторить попытку дулирования?",5+16+0,"ВОПРОС") = 4 THEN
llZanjato = .T.
ELSE
DO MyExit && уходим
ENDIF
ENDIF
ENDDO
* Резко закрываем активные базы и таблицы
CLOSE DATABASE ALL
lcMessError = myRun("WinRAR.exe",lcArgument) && архивация (или дублирование)
LOCAL ltDeltaTime && время ожидания, сек
ltDeltaTime = 60
StartDateTime = DATETIME()
*Ждем появления окна WinRAR или пока не истекло время ожидания
DO WHILE FindWindow(NULL,'WinRAR')=0
IF DATETIME() > StartDateTime + ltDeltaTime THEN && время ожидания появления окна
* 60 сек
MESSAGEBOX("Истекло время ожидания запуска архиватора."+CHR(10)+;
"Дублирование не выполнено!"+CHR(10)+;
"Возможно не установлен архиватор WinRar.",0+16+0,"ОШИБКА")
DO MyExit && уходим
ENDIF
ENDDO
*Ждем завершения работы WinRAR или пока не истекло время ожидания
ltDeltaTime = 300 && 5 минут
StartDateTime = DATETIME()
LOCAL ltDeltaTime && время ожидания, сек
DO WHILE FindWindow(NULL,'WinRAR')#0
IF DATETIME() > StartDateTime + ltDeltaTime THEN
* запросим выход или еще подождем 2 минуты
IF MESSAGEBOX('Истекло время ожидания завершения дублирования.'+CHR(10)+;
'Подождать еще 2 минуты?'+CHR(10)+CHR(10)+;
'ПОЯСНЕНИЕ: Если дублирование завершилось пока Вы думали, все равно'+;
' нажмите "Да". '+;
'Нажатие "Нет" приводит к прекращению дальнейшей работы.';
,4+32+0,"ВОПРОС") = 6 THEN
StartDateTime = DATETIME()
ltDeltaTime = 120 && 2 минуты
ELSE
DO MyExit && уходим
ENDIF
ENDIF
ENDDO
ON ERROR &lcOldError && восстановить обработчик ошибок
* проверяем результат дублирования на ошибки
IF NOT EMPTY(ALLTRIM(lcMessError)) THEN
MESSAGEBOX ("Ошибка при дублировании."+CHR(10)+;
"Дублирование не выполнено!"+CHR(10)+;
"Возможно не установлен архиватор WinRar.",0+16+0,"ОШИБКА")
DO MyExit && уходим
ELSE
* добавим дату сегодняшнего дублирования
SELECT 0
USE DatesDubl
APPEN BLANK
REPLACE DatesDubl.dLastDubl WITH DATE()
USE
ENDIF
ELSE
DO MyExit && клиент отказался дублировать! Его дело! Уходим
ENDIF
ELSE
SELECT DatesDubl && закрываем таблицу с историей дублирования. Она нам больше не нужна
USE
ENDIF
ENDPROC
********************************************************************
FUNCTION myRun
* Функция, которая ищет файл и запускает соответствующее приложение для
этого файла
* С помощью данной функции можно запускать программы (например, WinRar)
LPARAMETERS cFile, cAtribut
LOCAL lcAtribut
* а передается ли атрибут для вызываемого файла?
IF PARAMETERS()<2 THEN
lcAtribut = "" && нет параметра для передачи
ELSE
lcAtribut = cAtribut && передаваемый параметр
ENDIF
LOCAL nWhnd, cStartPath, nResult, cMsg
DECLARE INTEGER ShellExecute IN SHELL32 INTEGER hwnd, STRING cOP, STRING
cFile, ;
STRING cParams, STRING cStartDir, INTEGER nShowCmd
DECLARE INTEGER GetDesktopWindow IN User32
nWhnd = GetDesktopWindow()
cStartPath = ADDBS(JUSTPATH(cFile))
*!* nResult = ShellExecute(nWhnd, 'OPEN', cFile, '', cStartPath, 1)
nResult = ShellExecute(nWhnd, 'OPEN', cFile, lcAtribut, cStartPath, 1)
cMsg = ''
IF nResult < 0x32
DO CASE
CASE nResult = 2 && File not found
cMsg = 'Файл не найден'
CASE nResult = 3 && Path not found
cMsg = 'Неверный путь'
CASE nResult = 5 && Access denied
cMsg = 'Запуск невозможен'
CASE nResult = 8 && Not enough memory
cMsg = 'Недостаточно памяти для запуска приложения'
CASE nResult = 0x32 && DLL Not found
cMsg = 'DLL не найдена'
CASE nResult = 0x26 && Sharing violation
cMsg = 'Попытка совместного доступа'
CASE nResult = 0x27 && Invalid file association
cMsg = 'Неправильная ассоциация файла'
CASE nResult = 0x28 && DDE Timeout
cMsg = 'DDE Timeout'
CASE nResult = 0x29 && DDE Fail
cMsg = 'DDE Fail'
CASE nResult = 0x30 && DDE Busy
cMsg = 'DDE занято'
CASE nResult = 0x31 && No association
cMsg = 'С данным файлом не сопоставлено никакое приложение'
CASE nResult = 0x11 && Invalid EXE format
cMsg = 'Неверный формат EXE'
OTHERWISE
cMsg = 'Неизвестная ошибка'
ENDCASE
ENDIF
RETURN cMsg
ENDFUNC
*************************************************************************
PROCEDURE Zaglushka
* ЗАГЛУШКА
RETURN
ENDPROC
Автор публикации
