main.pas

本软件实现单机数据压缩打包备份功能.数据压缩级别,压缩速度可选!备份可采取增量备份或全备份.

unit Main;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, ExtCtrls, ComCtrls, FileCtrl, Buttons, backup, Menus;

type
  TBackupDialog = class(TForm)
    OpenDialog: TOpenDialog;
    Backupfile1: TBackupFile;
    PageControl1: TPageControl;
    BackupTabSheet: TTabSheet;
    RestoreTabSheet: TTabSheet;
    FileListBox: TListBox;
    SaveDialog: TSaveDialog;
    FileListBox1: TFileListBox;
    DriveComboBox1: TDriveComboBox;
    DirectoryListBox1: TDirectoryListBox;
    ArchiveTitleEdit: TEdit;
    rgRestoreMode: TRadioGroup;
    Label3: TLabel;
    gbRestorepath: TGroupBox;
    rbOrigpath: TRadioButton;
    rbOtherPath: TRadioButton;
    EdPath: TEdit;
    CbFullPath: TCheckBox;
    ArchiveContentEdit: TEdit;
    Label4: TLabel;
    MeFiles: TMemo;
    AddFilesBitBtn: TBitBtn;
    AddWildCardsBitBtn: TBitBtn;
    ClearBitBtn: TBitBtn;
    OpenSetBitBtn: TBitBtn;
    SaveSetBitBtn: TBitBtn;
    BackupBitBtn: TBitBtn;
    CancelBitBtn: TBitBtn;
    OptionsGroupBox: TGroupBox;
    CbSaveFileID: TCheckBox;
    BackupModeRadioGroup: TRadioGroup;
    CompressionLevelRadioGroup: TRadioGroup;
    SaveSetAsBitBtn: TBitBtn;
    RestoreBitBtn: TBitBtn;
    CancelRestoreBitBtn: TBitBtn;
    BackupTitleLabel: TLabel;
    BackupTitleEdit: TEdit;
    BackupSetEdit: TEdit;
    BackupSetLabel: TLabel;
    DeleteBitBtn: TBitBtn;
    DefaultSetBitBtn: TBitBtn;
    RestorePathButton: TSpeedButton;
    UpButton: TSpeedButton;
    DownButton: TSpeedButton;
    SortListCheckBox: TCheckBox;
    WhatsThisPopupmenu: TPopupMenu;
    Popupwhatsthis: TMenuItem;
    ProgressBar1: TProgressBar;
    Label1: TLabel;
    Label2: TLabel;
    procedure Backupfile1Progress(Sender: TObject; Filename: String;
      Percent: TPercentage; var Continue: Boolean);
    procedure FileListBox1Click(Sender: TObject);
    procedure rbOrigpathClick(Sender: TObject);
    procedure AddFilesBitBtnClick(Sender: TObject);
    procedure AddWildCardsBitBtnClick(Sender: TObject);
    procedure ClearBitBtnClick(Sender: TObject);
    procedure BackupBitBtnClick(Sender: TObject);
    procedure CancelBitBtnClick(Sender: TObject);
    procedure SaveSetBitBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure RestoreBitBtnClick(Sender: TObject);
    procedure OpenSetBitBtnClick(Sender: TObject);
    procedure SaveSetAsBitBtnClick(Sender: TObject);
    procedure BackupTitleEditChange(Sender: TObject);
    procedure FileListBoxClick(Sender: TObject);
    procedure DeleteBitBtnClick(Sender: TObject);
    procedure DefaultSetBitBtnClick(Sender: TObject);
    procedure PageControl1Change(Sender: TObject);
    procedure Backupfile1NeedDisk(Sender: TObject; DiskID: Word;
      var Continue: Boolean);
    procedure CompressionLevelRadioGroupClick(Sender: TObject);
    procedure BackupModeRadioGroupClick(Sender: TObject);
    procedure RestorePathButtonClick(Sender: TObject);
    procedure DownButtonClick(Sender: TObject);
    procedure UpButtonClick(Sender: TObject);
    procedure SortListCheckBoxClick(Sender: TObject);
    procedure DriveComboBox1Change(Sender: TObject);
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure BtnContexthelpClick(Sender: TObject);
    procedure BtnHelpTOCClick(Sender: TObject);
    procedure FormKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure PopupwhatsthisClick(Sender: TObject);
  private
    fBackupSet:String;
    fModified: Boolean;
//    procedure AppMessage(var Msg: TMsg; var Handled: Boolean);
//    function  HandleMouseMsg(CtlHandle: THandle; Button: TMouseButton; Shift: TShiftState; X, Y: Integer): boolean;

    function SaveFileSet(FileName: String): Boolean;
    procedure SetButtons;
  public
  end;

var
  BackupDialog: TBackupDialog;
  OldCursor: TCursor;
  Label_Flag:String;

const
  SELDIRHELP = 1000;
  
implementation

{$R *.DFM}

uses IniFiles;

procedure TBackupDialog.Backupfile1Progress(Sender: TObject; Filename: String;
  Percent: TPercentage; var Continue: Boolean);
begin
     with Progressbar1 do
     begin
     //     visible := Percent < 100;
          if visible then position := Percent;
     end;
     if Percent < 100 then
       begin
          if Label_Flag='Backup' then Label1.caption := ExtractFileName(Filename);
          if Label_Flag='Restore' then Label2.caption := ExtractFileName(Filename);
       end
     else
       begin
         if Label_Flag='Backup' then
            begin
              Label1.Width := 300;
              Label1.caption := '正在写盘 ...... ';
            end;
          if Label_Flag='Backup' then
            begin
              Label2.Width := 300;
              Label2.caption := '正在写盘 ...... ';
            end;
       end;
end;

procedure TBackupDialog.FileListBox1Click(Sender: TObject);
var
   FileList: tstringlist;
   I: integer;
   S, FA, SZ: string;
begin
     FileList := TStringlist.create;
     MeFiles.lines.clear;
     ArchiveTitleEdit.text := backupfile1.getArchiveTitle(Filelistbox1.filename, FileList);
     if ArchiveTitleEdit.text = '' then ArchiveContentEdit.text := ''
     else begin
       ArchiveContentEdit.text :='包含 '+ inttostr(backupfile1.FilesTotal)+' 个文件，总容量为：'+inttostr(round(backupfile1.SizeTotal/1024))+' KB';
       MeFiles.lines.beginupdate;
       for I := 0 to FileList.Count-1 do
       begin
            S  := copy(FileList[i],1,pos(#9,FileList[i])-1);  //file name
            FA := copy(FileList[i],pos(#9,FileList[i])+1,pos('=',FileList[i])-pos(#9,FileList[i])-1);  //file age
            FA := DateToStr(
                  FileDateToDateTime(
                  StrtoInt(FA)       //integer file date is system + language independent!
                  ));
            SZ := copy(FileList[i],pos('=',FileList[i])+1, length(FileList[i])-pos('=',FileList[i]));  //file size in Bytes
            MeFiles.lines.add(S + ' from ' + FA + ', ' + SZ + ' bytes');
       end;
       if FileList.count = 0 then MeFiles.lines.add('在这个压缩包里面没有额外的信息');
       MeFiles.lines.endupdate;
     end;
     FileList.Free;
     SetButtons;
end;

procedure TBackupDialog.rbOrigpathClick(Sender: TObject);
begin
  SetButtons;
end;

procedure TBackupDialog.AddFilesBitBtnClick(Sender: TObject);
var
   I: Integer;
begin
  Opendialog.FileName := '';
  OpenDialog.InitialDir := ExtractFilePath(Application.ExeName);
  OpenDialog.Filter := 'All Files (*.*)|*.*|xBase Files (*.dbf, *.fpt)|*.dbf;*.fpt|List Files (*.lst)|*.lst|Data Files (*.dta)|*.dta';
  if OpenDialog.Execute then with FileListbox.Items do
    begin
      BeginUpdate;
      for I := 0 to OpenDialog.files.count-1 do
      if indexof(lowercase(OpenDialog.files[i])) = -1 then
        Add(lowercase(OpenDialog.files[i]));
      EndUpdate;
      fModified := True;
    end;
  SetButtons;
end;

procedure TBackupDialog.AddWildCardsBitBtnClick(Sender: TObject);
var
   S: string;
begin
  S := ExtractFilePath(Application.ExeName)+'*.*';
  if InputQuery('按自定义方式追加文件', '请输入文件路径和文件掩码', S) then
    begin
      FileListBox.items.add(S);
      fModified := True;
    end;
  SetButtons;
end;

procedure TBackupDialog.ClearBitBtnClick(Sender: TObject);
begin
  if fModified then
    if MessageDlg('你想保存相应的更改吗？',mtConfirmation,
      [mbYes,mbNo], 0) = mrYes then
      SaveSetBitBtnClick(NIL);

  FileListBox.Items.Clear;
  BackupSetEdit.Text := '未命名';
  BackupTitleEdit.Text := '我的备份';
  fBackupSet := '';
  fModified := False;
  SetButtons;
end;

procedure TBackupDialog.BackupBitBtnClick(Sender: TObject);
var
  NewName: String;
  Success: Boolean;
  CurrentDate,Year,Month,Day:String;
  SysTime: TsystemTime;
begin
   Label_Flag:='Backup';
{  if (CompressionLevelRadioGroup.ItemIndex >=0) and
    (CompressionLevelRadioGroup.ItemIndex < 3)then
    if MessageDlg('You have elected to compress your Backup Data.'+#13+#13
    +'The compression routine is an Industry Standard one, but was not created '
    +'by Vertical Software.  We are therefore unable to guarantee a resolution '
    +'in the extremely unlikely event that a problem arises with compressed Backups.'
    +#13+#13+'To continue and make a compressed Backup, click Yes.  To Backup '
    +'without compression, click No and then set the Compression Level Option '
    +'to None before commencing the Backup.'
    +#13+#13+'Do you want to continue?',mtConfirmation,
      [mbYes,mbNo], 0) = mrNo then
        Exit;  }
  NewName := Copy(fBackupSet, 0, Pos('.', fBackupSet)-1);
  GetSystemTime(SysTime);
  Year:=IntToStr(SysTime.wYear);
  Month:=IntToStr(SysTime.wMonth);
  if Length(Month)=1 then Month:='0'+Month;
  Day:=IntToStr(SysTime.wDay);
  if  Length(Day)=1 then Day:='0'+Day;         
  CurrentDate:=Year+Month+Day;
  NewName :=ExtractFileName(NewName)+CurrentDate;
  SaveDialog.InitialDir := ExtractFilePath(Application.ExeName);
  SaveDialog.FileName := NewName;
  SaveDialog.Filter := 'Backup archives (*.bck)|*.bck';
  SaveDialog.Title := 'Create Backup';
  SaveDialog.Options := [ofOverwritePrompt, ofHideReadOnly];
  with SaveDialog do if execute then
    begin
      if uppercase(copy(filename, 1, 1)) = 'A' then
        begin
          Showmessage('驱动器A是一个软驱， 请插入一张新的空白软盘！');
          BackupFile1.maxSize := 1400000;  //backup to floppy
        end
      else
        BackupFile1.maxSize := 0;

      BackupFile1.BackupTitle      := BackupTitleEdit.text;
      BackupFile1.BackupMode       := TBackupMode(BackupModeRadioGroup.ItemIndex);
      BackupFile1.CompressionLevel := TCompressionLevel(CompressionLevelRadioGroup.Itemindex);
      BackupFile1.SaveFileID       := CbSaveFileID.checked;

      try
        Screen.Cursor := crAppStart;
        AddFilesBitBtn.Enabled := False;
        AddWildCardsBitBtn.Enabled := False;
        DefaultSetBitBtn.Enabled := False;
        DeleteBitBtn.Enabled := False;
        ClearBitBtn.Enabled := False;
        AddWildCardsBitBtn.Enabled := False;
        OpenSetBitBtn.Enabled := False;
        SaveSetBitBtn.Enabled := False;
        SaveSetAsBitBtn.Enabled := False;
        BackupBitBtn.Enabled := False;
        CancelBitBtn.Caption := '&Cancel';

        ProgressBar1.Visible := True;
        Success := BackupFile1.Backup(FileListbox.Items, filename);
      finally
        Label1.Caption := '';
      //  ProgressBar1.Visible := False;
        CancelBitBtn.Caption := '&Close';
        SetButtons;
        Screen.Cursor := crDefault;
      end;

      if Success then
        Showmessage('恭喜您，备份成功！压缩率为：'+inttostr(BackupFile1.compressionrate)+' %')
           else Showmessage('备份失败或被中断！');
     end;
end;

procedure TBackupDialog.CancelBitBtnClick(Sender: TObject);
begin
  if not BackupFile1.Busy then
    begin
      if fModified then
        if MessageDlg('你想保存相应的更改吗？',mtConfirmation,
          [mbYes,mbNo], 0) = mrYes then
          SaveSetBitBtnClick(NIL);
      Close;
    end
  else
    if MessageDlg('你想中止备份吗？',mtConfirmation,
      [mbYes,mbNo], 0) = mrYes then
      Backupfile1.Stop;

end;

procedure TBackupDialog.SaveSetBitBtnClick(Sender: TObject);
begin
  // Check for no Title

  if fBackupSet = '' then
    begin
      SaveSetAsBitBtnClick(NIL);
      Exit;
    end;
  if not SaveFileSet(fBackupSet) then
    MessageDlg('不能保存当前的备份集！', mtError, [mbOk], 0);
end;

{function TBackupDialog.HandleMouseMsg(CtlHandle: THandle; Button: TMouseButton; Shift: TShiftState; X, Y: Integer): boolean;
var
   FocusCtl: TWinControl;
   ClickCtl: TControl;
   ContextID: integer;
   Pt: TSmallPoint;

   function FindFocusControl(Ctl: TWinControl): TWinControl;
   var
      i: integer;
   begin
     

     Result := nil;
     if Ctl.handle = CtlHandle then
       result := Ctl
     else if (Ctl is TCustomCombobox)
       and (ChildWindowfromPoint(Ctl.handle, point(x,y)) = CtlHandle) then
       result := Ctl
     else
       begin
         for i := 0 to Ctl.controlcount-1 do
           begin
             if (Ctl.controls[i] is TWinControl) then result := FindFocusControl(TWinControl(ctl.controls[i]));
             if result <> nil then break;
           end;
       end;
   end;

   function FindContextID(Ctl: TControl): integer;
   begin
     Result := 0;

     if (Ctl is TWinControl) then
       Result := TWinControl(Ctl).helpcontext
     else if (Ctl is TGraphicControl) then
       Result := Ctl.tag;

     if (Ctl is TLabel) and (TLabel(Ctl).FocusControl <> nil) then
       Result := TLabel(Ctl).FocusControl.helpcontext;

     
     if (result = 0) and (Ctl.parent <> nil) then
       result := FindContextID(Ctl.parent);
   end;

begin
  Result := false;
  FocusCtl := FindFocusControl(self);
  if FocusCtl = nil then
    FocusCtl := self;
  ClickCtl := FocusCtl.controlatpos(point(x,y), true);
  if (ClickCtl = nil) then
    ClickCtl := FocusCtl;

 
  ContextID := FindContextID(ClickCtl);
  if ContextID = 0 then
    ContextID := 1000;

  case Button of
    mbLeft:  if (ClickCtl <> BtnContextHelp) then
              begin
                Pt := PointToSmallPoint(FocusCtl.Clienttoscreen( point(x,y) ));

                if ContextID < 0 then
                  Application.HelpCommand(HELP_CONTEXT, abs(ContextID))
                else
                  begin
                    Application.HelpCommand(HELP_SETPOPUP_POS, Longint(Pt));
                    Application.HelpCommand(HELP_CONTEXTPOPUP, ContextID);
                  end;
                Result := true;
              end;
     mbRight: begin
                result := (not (ClickCtl is TCustomEdit)) and (not (ClickCtl is TCustomComboBox));
                if result then
                  begin
                    PopupWhatsthis.tag := ContextID;
                    Pt := PointToSmallPoint(FocusCtl.Clienttoscreen( point(x,y) ));
                    if TLabel(ClickCtl).PopupMenu = nil then
                      WhatsThisPopupmenu.popup(Pt.x, Pt.y)
                    else
                      TLabel(ClickCtl).PopupMenu.popup(Pt.x, Pt.y);
                   end;
              end;
     end;
end; }

{procedure TBackupDialog.AppMessage(var Msg: TMsg; var Handled: Boolean);
begin