【delphi开源代码栏目提醒】:文章导读:在新的一年中,各位网友都进入紧张的学习或是工作阶段。网学会员整理了delphi开源代码-BackUpUnit.pas的相关内容供大家参考,祝大家在新的一年里工作和学习顺利!
unit BackUpUnit;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, StdCtrls, shellapi;
type
TBackUpForm = class(TForm)
Panel1: TPanel;
Edit_path: TEdit;
Label3: TLabel;
Label4: TLabel;
Select: TButton;
Panel_button: TPanel;
Bevel_button: TBevel;
OKBtn: TButton;
CancelBtn: TButton;
procedure OKBtnClick(Sender: TObject);
procedure Edit_pathChange(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure SelectClick(Sender: TObject);
procedure CancelBtnClick(Sender: TObject);
procedure Edit_pathEnter(Sender: TObject);
private
{ Private declarations }
public
B_showmessage: boolean;
{ Public declarations }
end;
var
BackUpForm: TBackUpForm;
implementation
uses FunctionUnit, SelectDirUnit;
{$R *.dfm}
procedure TBackUpForm.OKBtnClick(Sender: TObject);
var
SFilePath, DFilePath, SourcePath: string;
MesString: string;
OpStruc: TSHFileOpStruct;
FromBuf, ToBuf: array[0..255] of Char;
ShouldCopy: Boolean;
sr: TSearchRec;
FileAttrs: Integer;
label COPYAGAIN;
begin
COPYAGAIN:
// 准备目录拷贝
FillChar(FromBuf, Sizeof(FromBuf), 0);
FillChar(ToBuf, Sizeof(ToBuf), 0);
// 设置OpStruc
with OpStruc do
begin
Wnd := Handle;
wFunc := FO_COPY;
pFrom := @FromBuf;
pTo := @ToBuf;
fFlags := FOF_NOCONFIRMATION or FOF_RENAMEONCOLLISION;
fAnyOperationsAborted := False;
hNameMappings := nil;
lpszProgressTitle := nil;
end;
SourcePath := ExtractFileDir(Application.ExeName);
if (StrLen(PChar(SourcePath)) <> 3) then
SourcePath := SourcePath + '\';
FillChar(FromBuf, Sizeof(FromBuf), 0);
FillChar(ToBuf, Sizeof(ToBuf), 0);
SFilePath := SourcePath + 'data';
StrPCopy(FromBuf, Pchar(SFilePath));
DFilePath := Edit_path.Text;
StrPCopy(ToBuf, Pchar(DFilePath));
// 检测源路径是否存在
if (not DirectoryExists(SFilePath)) then
begin
if B_showmessage then
begin
MesString := '源数据库目录' + SFilePath + '已被破坏,系统不能进行备份。';
MessageBox(Handle, PChar(MesString), '错误', MB_OK + MB_ICONERROR);
end;
exit;
end;
if uppercase(SFilePath) = uppercase(DFilePath) then
begin
if B_showmessage then
begin
MesString := '源数据库目录与目标数据库目录相同,系统不能进行备份。';
MessageBox(Handle, PChar(MesString), '错误', MB_OK + MB_ICONERROR);
end;
exit;
end;
// 检测目的路径是否存在
ShouldCopy := True;
if (DirectoryExists(DFilePath)) then
begin
if B_showmessage then
begin
MesString := '目的路径 ' + DFilePath + ' 已经存在,继续备份会删除该文件夹下的所有文件。' + chr(13) + '是否继续备份至该目录?';
if MessageBox(Handle, PChar(MesString), '信息', MB_YESNO + MB_ICONINFORMATION) <> IDYES then
ShouldCopy := False
else //先删除该文件夹
begin
OpStruc.wFunc := FO_DELETE;
StrPCopy(FromBuf, Pchar(DFilePath));
ShFileOperation(OpStruc);
goto COPYAGAIN; //删除已存在的目录文件夹后重新COPY
end;
end
else
begin
OpStruc.wFunc := FO_DELETE;
StrPCopy(FromBuf, Pchar(DFilePath));
ShFileOperation(OpStruc);
goto COPYAGAIN; //删除已存在的目录文件夹后重新COPY
end;
end;
if ShouldCopy then
begin
if ShFileOperation(OpStruc) <> 0 then
begin
MesString := '在备份目录' + SFilePath + '的过程中出现错误。';
MessageBox(Handle, PChar(MesString), '错误', MB_OK + MB_ICONERROR);
end
else // 将文件的属性设置为不是只读属性
begin
FileAttrs := faAnyFile;
if FindFirst(DFilePath + '\*.*', FileAttrs, sr) = 0 then
begin
FileSetAttr(DFilePath + '\' + sr.Name, faArchive);
end;
while FindNext(sr) = 0 do
begin
FileSetAttr(DFilePath + '\' + sr.Name, faArchive);
end;
FindClose(sr);
if B_showmessage then
begin
showmessage('所有数据已安全备份至“' + dfilepath + '”!');
self.Close;
end;
end;
end;