fm_datebackup.pas

档案资料管理系统

unit FM_DateBackUp;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, Buttons,FileCtrl,StrUtils, ComCtrls;//ShlObj;

type
  TFM_DateBackUp1 = class(TForm)
    GroupBox1: TGroupBox;
    RadioButton1: TRadioButton;
    RadioButton2: TRadioButton;
    Edit1: TEdit;
    Label1:TLabel;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    ProgressBar1: TProgressBar;
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
    procedure GetDirectories(Directory: string; IncludeFiles: boolean);
    procedure GetDirectories1(Directory1: string; IncludeFiles1: boolean);
    procedure GetDirectories2(Directory2: string; IncludeFiles2: boolean);
    procedure GetDirectories3(Directory3: string; IncludeFiles3: boolean);
    procedure Copy_File(Source: String;Target:String);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FM_DateBackUp1: TFM_DateBackUp1;
  FromF, ToF: file;
  NumRead, NumWritten: Integer;
  Buf: array[1..2048] of Char;
  FMDBUPPath:String;
  FMDBUPPath1:string;
  FMDBUPPath2:string;
implementation

{$R *.dfm}

procedure TFM_DateBackUp1.BitBtn1Click(Sender: TObject);
var
 {SHFF:_Browseinfo;
 ReturnPath:PChar;}
 ReturnPath:string;
begin
 if RadioButton1.Checked then
   begin
    SelectDirectory('选择备份文件夹','',ReturnPath);
    if RightStr(ReturnPath,1)='\' then
       Edit1.Text:=ReturnPath
    else
       Edit1.Text:=ReturnPath+'\'
   { SHFF.hwndOwner:=FM_DateBackUp1.Handle;
    SHFF.pidlRoot:=nil;
    SHFF.lpfn:=nil;
    SHFF.pszDisplayName:=PChar('文件修复');
    SHFF.lpszTitle:=PChar('选择备份文件夹');
    SHFF.ulFlags:=BIF_RETURNONLYFSDIRS ;
    GetMem(ReturnPath,255);
    D:=SHBrowseForFolder(SHFF);
    SHGetPathFromIDList(,ReturnPath);
    Edit1.Text:=ReturnPath;
    FreeMem(ReturnPath);  }
   end;
 if RadioButton2.Checked then
   begin
    SelectDirectory('选择还原文件夹','',ReturnPath);
    if RightStr(ReturnPath,1)='\' then
       Edit1.Text:=ReturnPath
    else
       Edit1.Text:=ReturnPath+'\'
   end;
end;
procedure TFM_DateBackUp1.BitBtn2Click(Sender: TObject);
begin
 if (RadioButton1.Checked) and (Edit1.Text<>'\') and (Edit1.Text<>'') then
   begin
     if DirectoryExists(Edit1.Text) then
       begin
        Caption:='正在备份文件请稍候......';
        ProgressBar1.Visible:=True;
        FMDBUPPath:='';
        FMDBUPPath2:='Project\';
        FMDBUPPath1:=ExtractFilePath(Application.ExeName)+'Project\';
        GetDirectories(FMDBUPPath1,True);
        GetDirectories1(FMDBUPPath1,True);
        FMDBUPPath2:='Otherfile\SaveFile\';
        CreateDir(Edit1.Text+'OtherFile\');
        FMDBUPPath1:=ExtractFilePath(Application.ExeName)+'Otherfile\SaveFile\' ;
        GetDirectories(FMDBUPPath1,True);
        GetDirectories1(FMDBUPPath1,True);
        Caption:='数据修复';
        ProgressBar1.Visible:=False;
        Application.MessageBox('文件备份完毕','真诚提醒您',MB_OK or MB_ICONINFORMATION);
       end
     else
       Application.MessageBox('请填写正确的路径','真诚提醒您',MB_OK or MB_ICONINFORMATION);
   end;
 if (RadioButton2.Checked) and (Edit1.Text<>'\') and (Edit1.Text<>'') then
   begin
    if DirectoryExists(Edit1.Text) then
      begin
       if Application.MessageBox('需要还原的文件有可能比较老，还原后将覆盖'+#13+'现有的文件，这样将删除新加入的记录。'+#13+#13+#13'          确实要继续吗？','真诚提醒您',MB_YESNO or MB_ICONQUESTION)=IDYES then
        begin
          if (DirectoryExists(Edit1.Text+'Project\')) and (DirectoryExists(Edit1.Text+'OtherFile\SaveFile\')) then
            begin
              Caption:='正在还原文件请稍候......';
              ProgressBar1.Visible:=True;
              FMDBUPPath:='';
              FMDBUPPath2:='Project\';
              FMDBUPPath1:=Edit1.Text+'Project\';
              GetDirectories2(FMDBUPPath1,True);
              GetDirectories3(FMDBUPPath1,True);
              FMDBUPPath2:='Otherfile\SaveFile\';
              FMDBUPPath1:=Edit1.Text+'Otherfile\SaveFile\' ;
              GetDirectories2(FMDBUPPath1,True);
              GetDirectories3(FMDBUPPath1,True);
              Caption:='数据修复';
              ProgressBar1.Visible:=False;
              Application.MessageBox('文件还原完毕','真诚提醒您',MB_OK or MB_ICONINFORMATION);
           end
          else
            Application.MessageBox('缺少还原文件，还原不能继续','真诚提醒您',MB_OK or MB_ICONINFORMATION);
        end;
      end
   else
     Application.MessageBox('请填写正确的路径','真诚提醒您',MB_OK or MB_ICONINFORMATION);
   end;
end;

procedure TFM_DateBackUp1.Copy_File(Source, Target: String);
begin
 begin
 ProgressBar1.Position:=0;
 AssignFile(FromF, Source);
 Reset(FromF, 1);
 AssignFile(ToF, Target);
 Rewrite(ToF, 1);
 ProgressBar1.Max:= FileSize(FromF);
 ProgressBar1.Min:=0;
 repeat
  BlockRead(FromF, Buf, SizeOf(Buf), NumRead);
  BlockWrite(ToF, Buf, NumRead, NumWritten);
  ProgressBar1.Position:=ProgressBar1.Position+Numread;
 until (NumRead = 0) or (NumWritten <> NumRead);
  CloseFile(FromF);
  CloseFile(ToF);
 end;
end;

procedure TFM_DateBackUp1.GetDirectories(Directory: string;IncludeFiles: boolean);
var
 SearchRec: TSearchRec;
begin
 CreateDir(Edit1.Text+FMDBUPPath2+RightStr(Directory,(Length(Directory)-Length(FMDBUPPath1))));
 if Directory[length(Directory)] <> '\' then
    Directory:= Directory + '\';
 if FindFirst(Directory + '*.*',faDirectory,SearchRec) = 0 then
    begin
     repeat
      if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
          begin
           if (SearchRec.Attr and faDirectory > 0) then
              begin
               GetDirectories(Directory + SearchRec.Name,IncludeFiles);
              end;
          end
     until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
   end;
end;
procedure TFM_DateBackUp1.GetDirectories1(Directory1: string;IncludeFiles1: boolean);
var
 SearchRec: TSearchRec;
begin
 if Directory1[length(Directory1)] <> '\' then
    Directory1:= Directory1 + '\';
 if FindFirst(Directory1 + '*.*',faDirectory,SearchRec) = 0 then
    begin
     repeat
      if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
          begin
           if (SearchRec.Attr and faDirectory > 0) then
            begin
             GetDirectories1(Directory1 + SearchRec.Name,IncludeFiles1);
            end;
          end
       else if IncludeFiles1 then
             if SearchRec.Name[1] <> '.' then
                Copy_File(Directory1+SearchRec.Name,Edit1.Text+FMDBUPPath2+RightStr(Directory1,(Length(Directory1)-Length(FMDBUPPath1))) +SearchRec.Name);
     until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
   end;
end;
procedure TFM_DateBackUp1.GetDirectories2(Directory2: string;
  IncludeFiles2: boolean);
var
 SearchRec: TSearchRec;
begin
 CreateDir(ExtractFilePath(Application.ExeName)+FMDBUPPath2+RightStr(Directory2,(Length(Directory2)-Length(FMDBUPPath1))));
 if Directory2[length(Directory2)] <> '\' then
    Directory2:= Directory2 + '\';
 if FindFirst(Directory2 + '*.*',faDirectory,SearchRec) = 0 then
    begin
     repeat
      if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
          begin
           if (SearchRec.Attr and faDirectory > 0) then
              begin
               GetDirectories2(Directory2 + SearchRec.Name,IncludeFiles2);
              end;
          end
     until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
   end;
end;

procedure TFM_DateBackUp1.GetDirectories3(Directory3: string;
  IncludeFiles3: boolean);
var
 SearchRec: TSearchRec;
begin
 if Directory3[length(Directory3)] <> '\' then
    Directory3:= Directory3 + '\';
 if FindFirst(Directory3 + '*.*',faDirectory,SearchRec) = 0 then
    begin
     repeat
      if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
          begin
           if (SearchRec.Attr and faDirectory > 0) then
            begin
             GetDirectories3(Directory3 + SearchRec.Name,IncludeFiles3);
            end;
          end
       else if IncludeFiles3 then
             if SearchRec.Name[1] <> '.' then
                Copy_File(Directory3+SearchRec.Name,ExtractFilePath(Application.ExeName)+FMDBUPPath2+RightStr(Directory3,(Length(Directory3)-Length(FMDBUPPath1))) +SearchRec.Name);
     until FindNext(SearchRec) <> 0;
    FindClose(SearchRec);
   end;
end;
end.