unitcommbackup.~pas

此代码为企业原料管理代码

unit UnitCommBackup;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons, ExtCtrls, FileCtrl, ShellAPI;

type
  TfrmCommBackup = class(TForm)
    DriveComboBox1: TDriveComboBox;
    DirectoryListBox1: TDirectoryListBox;
    Panel1: TPanel;
    BitBtn1: TBitBtn;
    Edit1: TEdit;
    BitBtn2: TBitBtn;
    Label1: TLabel;
    Label2: TLabel;
    procedure DirectoryListBox1Change(Sender: TObject);
    procedure DriveComboBox1Change(Sender: TObject);
    procedure BitBtn1Click(Sender: TObject);
    procedure BitBtn2Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmCommBackup: TfrmCommBackup;

implementation

{$R *.DFM}

procedure TfrmCommBackup.DirectoryListBox1Change(Sender: TObject);
begin
  edit1.text:=DirectoryListBox1.Directory+'\'+'JL'+formatdatetime('yy"-"mm"-"dd',date);
end;

procedure TfrmCommBackup.DriveComboBox1Change(Sender: TObject);
begin
  edit1.text:=DirectoryListBox1.Directory+'\'+'JL'+formatdatetime('yy"-"mm"-"dd',date);
end;

procedure TfrmCommBackup.BitBtn1Click(Sender: TObject);
var
   lpFileOp: TSHFileOpStruct;
   sSourcePath,sTargetPath:string;
   i:integer;
   label lab;
begin
   sSourcePath:=ExtractFilePath(Application.Exename)+'db';
   sTargetPath:=edit1.text;
   showmessage(sSourcePath+'    ');
   if DirectoryExists(sTargetPath) then  //if1
   begin
      if messagedlg('已经有这个目录了,要覆盖原来的目录吗?',mtinformation,[mbyes,mbno],0) = mrno then //if2
        goto lab;
    begin //if2
//======================
// 删除原来的目录
//======================

       with lpFileOp do
         begin
         Wnd := Self.Handle;
        // wFunc := FO_delete;
         pFrom := pchar(sTargetPath);
         pTo := pchar(sTargetPath);
          wFunc := FO_delete;
         fFlags := FOF_ALLOWUNDO;
         hNameMappings := nil;
         lpszProgressTitle := nil;
         fAnyOperationsAborted := true;
       end; //with

       if SHFileOperation(lpFileOp) <> 0 then
         ShowMessage('删除失败');

     end; //if

    end;  //if2

//=====================
// 拷贝备份文件目录 db
//=====================
  // showmessage(sSourcePath+#13+#13+sTargetPath+'  '+inttostr(strlen(Pchar(sSourcePath))));
  // if messagedlg('您要将目前的数据备份至 '+edit1.text+' 目录下吗?',mtinformation,[mbyes,mbNo],0) = mrYes then
  // begin

    // showmessage(ssourcepath+'     '+stargetpath);

     with lpFileOp do
       begin
       Wnd := Self.Handle;
       pFrom := pchar(sSourcePath);
       pTo := pchar(sTargetPath);
       wFunc := FO_COPY;
       fFlags := FOF_ALLOWUNDO;
       hNameMappings := nil;
       lpszProgressTitle := nil;
       fAnyOperationsAborted := True;
     end; //with

    i:=SHFileOperation(lpFileOp);
    if i <> 0 then
       ShowMessage('删除失败');
    if i = 0 then
       messagedlg('备份完毕!',mtinformation,[mbok],0);
         exit;
      lab: messagedlg('请选择新备份目录!',mtinformation,[mbok],0);
   //  messagedlg('您取消了备份操作，请另选择一个目录.',mtinformation,[mbOk],0);
     exit;
end;


procedure TfrmCommBackup.BitBtn2Click(Sender: TObject);
begin
  close;
end;

end.