Утилита для бекапа
Данная программа просканирует указанный вами каталог и его дочерние каталоги и упакует все в архив ZIP. При желании может удалить все находящиеся в каталоге файлы. Есть возможность указать временной интервал созданных файлов в каталоге для упаковки. Исходник хорошо прокомментирован. Проверен на версии компилятора 1.05. Для компиляции необходимы библиотеки libzip , window9.
Платформа: Windows
Автор: >Quiet Snow<
' ' [ARHIVER.BAS] ' ' ' Простой архиватор файлов v0.9 ' Автор: >Quiet Snow< ' 20\02\2016 FreeBASIC Compiler : 0.90.0 (6.23.2013) ' FreeBASIC editor (FbEdit) : 1.0.7.6c ' ' ' Window9 #INCLUDE Once "window9.bi" ' LibZip #INCLUDE Once "zlib.bi" #INCLUDE Once "zip.bi" ' WinAPI #INCLUDE Once "windows.bi" #INCLIB "Shlwapi" ' В этой библиотеке лежит функция PathIsDirectoryA ' '>> Процедуры программы ' Declare Function PathIsDirectory Alias "PathIsDirectoryA" (Byval pszPath As LPCSTR) As Integer ' Работа с датами Declare Function ToUsableData (Source As Long) As String Declare Function TakeNumericData (GadgetNum As Integer) As Long Declare Function FileDataTimeToNumData (FDataSt As String) As Long ' Корректируем директорию Declare Function DirNameCorrect (DirName As String) As String ' Для сканирования Declare Function ScanDir(DirToScan As String, WorkMod As Short) As Integer Declare Sub ScanFILE (WhereIsFile As String, NameToScan As String, TekID As Integer, WorkMod As Short) ' Простая прослойка работы с архивами Declare Sub CreateZIP (ArhiveName As String) Declare Sub FileToZIP (RealFileName As String, LocationInZIP As String) Declare Sub CloseZIP () ' Функция перевода кодировки для функции упаковки в архив ' фиксит баг с кривым отображением русского текста в именах файлов Declare Function Ansi2Oem (TxtIn As Byte Ptr, TxtOut As LPSTR, TxtLen As Integer, Prover As Integer) As Integer ' Переменные и массивы Dim MyHWND As HWND, DirHWND As HWND, CalHWND1 As HWND, CalHWND2 As HWND ' Хендлы окон Dim ev As Integer ' ID События Dim Shared Chk1Err As Short, Chk2Err As Short ' Флаги ошибки установки даты Dim Shared Chk1 As Short, Chk2 As Short ' Флаги стоит ли дата Dim Shared Dat1 As Long, Dat2 As Long ' Дата в цифр. эквиваленте Dim Shared Pth As String, ZipName As String ' Путь и имя ZIP файла Dim Shared WorkInZip As Integer ' Создан ли ZIP файл и работаем ли с ним Dim Shared DobavZipError As Integer ' Есть ли ошибка при добавлении файлов в ZIP Dim Shared FrZ As Integer ' Хендл файла для проверки открытия ZIP файла Dim Shared CanZiCreate As Short ' Можно ли создать ZIP файл Dim Shared NeedDelete As Short ' Нужно ли удалять файлы Dim Shared ZiPtr As zip Ptr ' Хендлы для LibZip Dim Shared ZiSou As Zip_source Ptr ' Создадим основное окно программы MyHWND = OpenWindow("Резервное копирование", 10, 10, 700, 400) CenterWindow(MyHWND) ' Вставка, чтобы узнать цвет формы, против бага заднего цвета фона гаджетов ' каждому сбойному гаджету ставим цвет фона отдельно Dim DCForBkCv As HDC = GetDC(MyHWND) Dim Shared FormBack As COLORREF FormBack = GetPixel(DCForBkCv, 1, 1) ReleaseDC(MyHWND, DCForBkCv) ' Надпись, поле и кнопка для выбора директории TextGadget (1, 10, 10, 500, 30, "Папка, файлы и папки которой будем сканировать:", SS_SIMPLE) SetGadgetColor (1, FormBack, 0, 1) StringGadget (2, 10, 30, 600, 25, GetCurentDir() + "\", , WS_EX_CLIENTEDGE) ButtonGadget (3, 620, 30, 60, 25, ". . .") ' Надпись, поле для выбора имени архива TextGadget (15, 10, 80, 500, 30, "Имя архива:", SS_SIMPLE) SetGadgetColor (15, FormBack, 0, 1) StringGadget (16, 10, 100, 300, 25, "Backup.zip", , WS_EX_CLIENTEDGE) ' Надпись, поля и кнопки указания дат TextGadget (9, 10, 160, 550, 35, "Даты файлов, от и до которых(включительно) необходимо файлы запаковать, а после удалить их:") SetGadgetColor (9, FormBack, 0, 1) StringGadget (10, 10, 200, 100, 25, "--", ES_READONLY, WS_EX_CLIENTEDGE + WS_EX_DLGMODALFRAME) ButtonGadget (11, 120, 200, 150, 25, "Указать дату") StringGadget (12, 350, 200, 100, 25, "--", ES_READONLY, WS_EX_CLIENTEDGE + WS_EX_DLGMODALFRAME) ButtonGadget (13, 460, 200, 150, 25, "Указать дату") ' Чекбокс "Удалить запакованные файлы" CheckBoxGadget(14, 230, 250, 230, 20, "Удалить запакованные файлы") SetGadgetColor (14, FormBack, 0, 1) ' Кнопка "Проверить и запаковать" ButtonGadget (8, 250, 290, 200, 50, "Проверить и запаковать") Do ev = WaitEvent() ' Ожидаем события и получаем его идентификатор ' Обработаем события во всех гаджетах во всех окнах If ev = eventgadget Then Select Case eventnumber Case 3 ' Кнопка выбора пути основного окна DirHWND = OpenWindow("Укажите директорию", 10, 10, 440, 400) CenterWindow(DirHWND) ExplorerListGadget(30 , 10, 10) FlagExplorerListGadget(30, 1) ' Выводить только папки SetExplorerListGadgetPath(30, GetCurentDir()) ButtonGadget(31, 63, 320, 300, 30, "Указать путь") Case 31 ' Кнопка "указать путь" в окне выбора пути SetGadgetText(2, GetExplorerListGadgetPath(30)) Close_Window(DirHWND) Case 11 ' Кнопка выбора первой даты CalHWND1 = OpenWindow("Укажите первую дату", WindowX(MyHWND) - 100, WindowY(MyHWND) + 250, 450, 230) CalendarGadget(4, 0, -10, 220, 220) ButtonGadget(5, 230, 60, 200, 80, "Задать дату") DisableGadget (11, 1) Case 13 ' Кнопка выбора первой даты CalHWND2 = OpenWindow("Укажите вторую дату", WindowX(MyHWND) + 400, WindowY(MyHWND) + 250, 450, 230) CalendarGadget(6, 0, -10, 220, 220) ButtonGadget(7, 230, 60, 200, 80, "Задать дату") DisableGadget (13, 1) Case 14 ' Чекбокс "Удалить запакованные файлы" NeedDelete = GetGadgetState(14) Case 5 ' Кнопка "Задать дату" в окне выбора первой даты Chk1Err = 0 ' Ошибок пока нет Dat1 = TakeNumericData(4) ' Берём дату из 4-го гаджета(первого календаря) If Chk2 Then ' Если вторая дата уже стоит If Dat1 > Dat2 Then Chk1Err = -1 messagebox (CalHWND1, @"Установите дату ранее второй даты или равной ей", @"Ошибка", MB_OK Or MB_ICONERROR) End If End If If Not Chk1Err Then SetGadgetText(10, ToUsableData(Dat1)): Chk1 = -1 If Not Chk1Err Then Close_Window(CalHWND1): DisableGadget (11, 0) Case 7 ' Кнопка "Задать дату" в окне выбора второй даты Chk2Err = 0 ' Ошибок пока нет Dat2 = TakeNumericData(6) ' Берём дату из 6-го гаджета(второго календаря) If Chk1 Then ' Если первая дата уже стоит If Dat2 < Dat1 Then Chk2Err = -1 messagebox (CalHWND2, @"Установите дату позднее второй даты или равной ей", @"Ошибка", MB_OK Or MB_ICONERROR) End If End If If Not Chk2Err Then SetGadgetText(12, ToUsableData(Dat2)): Chk2 = -1 If Not Chk2Err Then Close_Window(CalHWND2): DisableGadget (13, 0) Case 8 ' Кнопка "проверить и запаковать" Pth = GetGadgetText(2, 2) ' Получим путь Pth = DirNameCorrect(Pth) SetGadgetText(2, Pth) ZipName = GetGadgetText(16) ' Получим имя ZIP архива FrZ = Freefile ' Проверить возможность создания ZIP файла If Open (ZipName, For Output, As FrZ) = 0 Then Close FrZ: Kill ZipName: Sleep 50, 1 CanZiCreate = -1 ' Можем создать ZIP-файл End If ' ' Запускаем процесс упаковки файлов ' If CanZiCreate Then If PathIsDirectory(Pth) Then DobavZipError = 0 DisableGadget (2, 1) ' Отключаем важные кнопки DisableGadget (3, 1) DisableGadget (11, 1) DisableGadget (13, 1) Sleep 50, 1 CreateZIP (ZipName) ScanDir(Pth, 1) ' Пакуем файлы CloseZIP () ' Удаляем файлы If NeedDelete = 1 Then Sleep 100, 1: ScanDir(Pth, 2) If DobavZipError Then MessageBox (MyHWND, @"Ошибки при добавлении файлов!", @"Ошибка!", MB_OK Or MB_ICONERROR) Else MessageBox (MyHWND, @"Успешно", @"ok", MB_OK) End If DisableGadget (2, 0) ' Включаем важные кнопки обратно DisableGadget (3, 0) DisableGadget (11, 0) DisableGadget (13, 0) Else MessageBox (MyHWND, @"Неверный путь!", @"Ошибка!", MB_OK Or MB_ICONERROR) End If End If End Select End If ' Атеперь строго по окнам ' События в основном окне If EventHwnd = MyHWND Then Select Case ev Case eventclose CloseWindow(MyHWND) End End Select ' Событие в окне указания пути Elseif EventHwnd = DirHWND Then Select Case ev Case eventclose CloseWindow(DirHWND) End Select ' Событие в окне первого календаря Elseif EventHwnd = CalHWND1 Then Select Case ev Case eventclose CloseWindow(CalHWND1) DisableGadget (11, 0) End Select ' Событие в окне первого календаря Elseif EventHwnd = CalHWND2 Then Select Case ev Case eventclose CloseWindow(CalHWND2) DisableGadget (13, 0) End Select End If Loop Sleep End ' Переведём дату из цифрового эквивалента в формат ГГГГ:ММ:ЧЧ Function ToUsableData (Source As Long) As String Dim Day As Long, Mes As Long, God As Long Dim Result As String * 10 Result = "0000.00.00" God = Source \ 10000 Mes = Source \ 100 - God * 100 Day = Source - God * 10000 - Mes * 100 MID$(Result, 1, 4) = STR$(God) MID$(Result, 6 + (2 - Len(STR$(Mes)))) = STR$(Mes) MID$(Result, 9 + (2 - Len(STR$(Day)))) = STR$(Day) ToUsableData = Result End Function ' Дату из гаджета календаря переведём в цифровой эквивалент ГГГГММЧЧ Function TakeNumericData (GadgetNum As Integer) As Long Dim Day As String, Mes As String, God As String Dim Result As String * 8 Day = STR$(GetStateCalendar(GadgetNum, 4)) Mes = STR$(GetStateCalendar(GadgetNum, 2)) God = STR$(GetStateCalendar(GadgetNum, 1)) Result = "00000000" MID$(Result, 1, 4) = God MID$(Result, 5 + (2 - Len(Mes))) = Mes MID$(Result, 7 + (2 - Len(Day))) = Day TakeNumericData = Val(Result) End Function ' Дату из файловой даты\времени в цифровой эквивалент ГГГГММЧЧ Function FileDataTimeToNumData (FDataSt As String) As Long Dim JustData As String, Dobav As String Dim Result As Long JustData = LEFT$(FDataSt, Instr(FDataSt, " ") - 1) Dobav = Dobav + RIGHT$(JustData, 4) Dobav = Dobav + MID$(JustData, 4, 2) Dobav = Dobav + LEFT$(JustData, 2) FileDataTimeToNumData = Val(Dobav) End Function ' Уберём многократные слэши справа от пути и точки Function DirNameCorrect (DirName As String) As String Dim s As String, Need As Short Dim NewName As String NewName = DirName UdalProver: s = RIGHT$(NewName, 2) Need = 0 If s = "\\" Then Need = -1 If s = "//" Then Need = -1 If s = "\/" Then Need = -1 If s = "/\" Then Need = -1 If s = "\." Then Need = -1 If s = "/." Then Need = -1 If s = ".." Then Need = -1 If Need Then NewName = LEFT$(NewName, Len(NewName) - 1): Goto UdalProver DirNameCorrect = NewName End Function ' ' Сканирование директории (Нерекурсивный вариант) ' Function ScanDir(DirToScan As String, WorkMode As Short) As Integer Dim DirLevels(5000) As Integer ' Уровни директорий ( Не думаю, что будет 5000 вложенных, но чем чёрт не шутит...) Dim TekDirLVL As Integer ' Текущий уровень Dim TekID As Integer ' Текущий ID Dim TekFNm As String ' Текущее имя директории Dim NowScanPath As String ' Сканируется этот путь Dim DEA As Integer ' DirectoryEntryAttributes Dim DirEntry As Integer Dim i As Integer = 0, UdSlsh As Integer NowScanPath = DirToScan Do: i = i + 1 ' Итераций ' Если нету поискового ID If DirLevels(TekDirLVL) = 0 Then ' Создадим поисковый ID DirLevels(TekDirLVL) = ExamineDirectory(NowScanPath, "*.*") Else ' Есть ли на этом уровне файлы\папки TekID = DirLevels(TekDirLVL) DirEntry = NextDirectoryEntry(TekID) ' Есть If DirEntry Then TekFNm = DirectoryEntryName(TekID) DEA = DirectoryEntryAttributes(TekID) ' Папка If DEA And FILE_ATTRIBUTE_DIRECTORY Then ' Не системная If TekFNm <> "." And TekFNm <> ".." Then TekDirLVL = TekDirLVL + 1 ' На следующий уровень поиска NowScanPath = NowScanPath + TekFNm + "\" End If ' Файл Elseif (DEA And FILE_ATTRIBUTE_DIRECTORY) = 0 Then ScanFILE (NowScanPath, TekFNm, TekID, WorkMode) End If ' Нет Else FinishDirectory(TekID) ' Закончим сканирование этой директории DirLevels(TekDirLVL) = 0 ' Предупредим что нет хендла у этого уровня TekDirLVL = TekDirLVL - 1 ' На предыдущий уровень поиска UdSlsh = Len(NowScanPath) If TekDirLVL < 0 Then Exit Do Do: UdSlsh = UdSlsh - 1 Loop Until Mid(NowScanPath, UdSlsh, 1) = "\" NowScanPath = Left(NowScanPath, UdSlsh) End If End If Loop ScanDir = i End Function ' Что делать при нахождении файла (проц. обработки найденного файла) ' Сюда программа приходит при каждом найденном файле Dim Shared FileKolic As Integer ' Общий счётчик файлов Dim Shared NumF As Integer ' Счётчик обработанных файлов Dim Shared Obrabotk As Integer ' Обрабатывать ли файл Dim Shared TekData As Long ' Дата текущего файла Dim Shared LocInZIP As String ' Путь в ZIP архиве Dim Shared NewLocInZIP As String ' Путь в ZIP архиве Dim Shared Resrv As Integer ' Длина новой строки Sub ScanFILE (WhereIsFile As String, NameToScan As String, TekID As Integer, WorkMode As Short) Obrabotk = -1 'PRINT NameToScan ' Получим дату текущего файла ' 1 - вр. создания 2 - Вр. последн. доступа 3 - Вр. изменения TekData = FileDataTimeToNumData(DirectoryEntryDate(TekID, 1)) ' Исключить ".zip" файлы из обработки If MID$(NameToScan, Instrrev(NameToScan, ".")) = ".zip" Then Obrabotk = 0 ' Если соотв. дата проставлена, то ограничиваем If TekData < Dat1 And Chk1 Then Obrabotk = 0 If TekData > Dat2 And Chk2 Then Obrabotk = 0 ' Пакуем файл If Obrabotk Then If WorkMode = 1 Then ' Режим запаковки LocInZIP = MID$(WhereIsFile, Len(Pth) + 1) + NameToScan ' Узнаем, сколько символов нужно для преобразования Resrv = Ansi2Oem (Sadd(LocInZIP), Sadd(NewLocInZIP), Len(LocInZIP), -1) 'PRINT Resrv, LocInZIP ' Заполним принимающую строку пробелами NewLocInZIP = SPACE$(Resrv - 1) ' Заполним принимающую строку пробелами ' Преобразуем юникод в OEM Resrv = Ansi2Oem (Sadd(LocInZIP), Sadd(NewLocInZIP), Len(LocInZIP), 0) ' Если преобразование успешно If Resrv Then ' То подрежем до той длины, которую нам дала функция перевода NewLocInZIP = LEFT$(NewLocInZIP, Resrv - 1) End If Print "File: " + NewLocInZIP + " is packing..."; FileToZIP (WhereIsFile + NameToScan, NewLocInZIP) Elseif WorkMode = 2 Then ' Режим удаления Print "Delete file: " + WhereIsFile + NameToScan + " ..."; Kill WhereIsFile + NameToScan End If Print " ok!" NumF = NumF + 1 End If 'PRINT NumF, NameToScan + !"\u" ' Отладка FileKolic = FileKolic + 1 If Inkey <> "" Then End End Sub ' Создать ZIP архив Sub CreateZIP (ArhiveName As String) If WorkInZip Then Exit Sub WorkInZip = -1 ZiPtr = zip_open(ArhiveName, ZIP_CREATE, 0) If ZiPtr = 0 Then WorkInZip = 0 ' Ошибка? End Sub ' Отправить файл в ZIP архив Sub FileToZIP (RealFileName As String, LocationInZIP As String) If WorkInZip Then ZiSou = zip_source_file(ZiPtr, RealFileName, 0, -1) ' Проверка на ошибку If ZiSou = 0 Then DobavZipError = -1: Print " ERROR!!! ": Exit Sub zip_add (ZiPtr, LocationInZIP, ZiSou) End If End Sub ' Закрыть открытый ZIP архив Sub CloseZIP () If WorkInZip = -1 And ZiPtr <> 0 Then zip_close (ZiPtr) WorkInZip = 0 End If End Sub ' ' Преобразует UTF8 строку в OEM строку. ' Function Ansi2Oem (TxtIn As Byte Ptr, TxtOut As LPSTR, TxtLen As Integer, Prover As Integer) As Integer Dim As Integer RetV, ReqBuff ' Возвр. знач, Сколько треб. символов Dim StMem As LPWSTR ' Буфер для мульти-байтового представления строки ' Узнаем на сколько букв нужно завести буфер для преобразования ' в мульти-байтовое представление ReqBuff = MultiByteToWideChar(CP_UTF8, 0, TxtIn, -1, NULL, 0) If Prover = -1 Then Ansi2Oem = ReqBuff: Exit Function ' 0 - ошибка(выходим) If ReqBuff = 0 Then Ansi2Oem = 0: Exit Function ' Заводим буфер StMem = Callocate(ReqBuff * 2, 1) ' Текст UTF8 в мульти-байтовое представление ReqBuff = MultiByteToWideChar(CP_ACP, 0, TxtIn, -1, StMem, ReqBuff * 2) ' Текст из мульти-байтового представления в OEM RetV = WideCharToMultiByte(CP_OEMCP, 0, StMem , ReqBuff, TxtOut, TxtLen, NULL, NULL)'CP_UTF8 ' Удалим буфер Deallocate (StMem) Ansi2Oem = RetV ' Вернём значение(кол-во байт, записанных в буфер) End Function
