unit Ucompactar;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, StdCtrls, DateUtils, ExtCtrls, ShellAPI, ComCtrls;
type
TFcompacta = class(TForm)
OpenDialog1: TOpenDialog;
Button1: TButton;
Edit1: TEdit;
Button3: TButton;
Edit3: TEdit;
ProgressBar1: TProgressBar;
CheckBox1: TCheckBox;
Label1: TLabel;
Label2: TLabel;
Label3: TLabel;
Button2: TButton;
procedure Button1Click(Sender: TObject);
procedure Button3Click(Sender: TObject);
procedure Button2Click(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
Fcompacta: TFcompacta;
cancel: Boolean;
Fuente,Fuente2,Fuente3, Destino,Destino2,Destino3:PChar;
implementation
{$R *.dfm}
procedure TFcompacta.Button1Click(Sender: TObject);
var varscad1, Nombre:string;
VarIcad1:Integer;
begin
if OpenDialog1.Execute then
begin
Edit1.Text:=OpenDialog1.FileName;
varscad1:=ExtractFileName(OpenDialog1.FileName);
varicad1:=Length(ExtractFileExt(OpenDialog1.FileName));
Destino:=PChar(ExtractFilePath(OpenDialog1.FileName)+Copy(varscad1,0,Length(varscad1)-VarIcad1)+Nombre+'SEG.FDB');
Destino2:=PChar(ExtractFilePath(OpenDialog1.FileName)+'Gbak.exe');
Destino3:=PChar(ExtractFilePath(OpenDialog1.FileName));
Fuente2:=PChar(ExtractFilePath(Application.ExeName)+'Gbak.exe');
Nombre:= StringOfChar('0',2-Length(IntToStr(DayOf(Now))))+IntToStr(DayOf(Now))+
StringOfChar('0',2-Length(IntToStr(MonthOf(Now))))+IntToStr(MonthOf(Now))+
StringOfChar('0',4-Length(IntToStr(YearOf(Now))))+IntToStr(YearOf(Now));
Edit3.Text:=Copy(varscad1,0,Length(varscad1)-VarIcad1)+Nombre+'.FBK';
Label3.Caption:=ExtractFilePath(OpenDialog1.FileName);
Fuente:=PChar(Edit1.Text);
end;
end;
procedure TFcompacta.Button2Click(Sender: TObject);
begin
Application.Terminate;
end;
procedure TFcompacta.Button3Click(Sender: TObject);
function ProgressRoutine(TotalFileSize, TotalBytesTransferred, StreamSize, StreamBytesTransferred: LARGE_INTEGER; dwStreamNumber, dwCallbackReason: DWORD; hSourceFile, hDestinationFile: THandle; lpData: Pointer): DWORD; stdcall;
//------------------------------------------------------------------------------
// Funcion del compañero escafandra bajado de
// http://www.delphiacc...reso-en-delphi/
//------------------------------------------------------------------------------
var
Value: integer;
begin
Application.ProcessMessages();
if(dwCallbackReason = CALLBACK_CHUNK_FINISHED) then
Fcompacta.ProgressBar1.Position:= (int64(TotalBytesTransferred) * 100) div int64(TotalFileSize);
Result:= PROGRESS_CONTINUE;
end;
var
lpOperation, lpFile, lpParameters, lpDirectory: PChar;
varbPasado:Boolean;
begin
varbPasado:=False;
if not FileExists(Edit3.Text) then
with TPanel.Create(nil) do
try
Caption:= 'Realizando copia de seguridad, aguarde un momento por favor...';
Font.Size:= 14;
Font.Name:= 'Arial';
Width:= 600;
Height:= 70;
Left:= (Self.ClientWidth - Width) div 2;
Top:= (Self.ClientHeight - Height) div 2;
BevelInner:= bvNone;
BevelOuter:= bvNone;
BevelWidth:= 1;
BorderStyle:= bsSingle;
Ctl3D:= False;
Parent:= Self;
lpOperation:= 'open';
lpFile:= 'gbak.exe';
lpParameters:= PChar('-b -v -t -user SYSDBA -password "masterkey" "'+ Edit1.Text +'" "'+label3.Caption+Edit3.text+'"');
lpDirectory:=PChar(ExtractFilePath(Application.Name));
ShellExecute(Handle, lpOperation, lpFile, lpParameters, lpDirectory, SW_HIDE);
varbPasado:=true
finally
if varbPasado=true then ShowMessage('Proceso terminado')
else ShowMessage('El fichero ya existe');
Free;
end; //hasta aqui ok
varbPasado:=False;
if (Edit3.Text<>'') and (Edit1.Text<>'') then
begin
if CheckBox1.Checked then //Si deseamos hacer una copia del original
begin
Cancel:= false;
Label1.Caption:='Copiando fichero';
CopyFileEx(PWideChar(Edit1.Text), Destino, @ProgressRoutine, nil, @Cancel, 0);
ShowMessage(SysErrorMessage(GetLastError()));
end;
with TPanel.Create(nil) do
try
cancel:=False;
Caption:= 'Restaurando copia de seguridad, aguarde un momento por favor...';
Font.Size:= 14;
Font.Name:= 'Arial';
Width:= 600;
Height:= 70;
Left:= (Self.ClientWidth - Width) div 2;
Top:= (Self.ClientHeight - Height) div 2;
BevelInner:= bvNone;
BevelOuter:= bvNone;
BevelWidth:= 1;
BorderStyle:= bsSingle;
Ctl3D:= False;
Parent:= Self;
lpOperation:= 'open';
lpFile:= 'gbak.exe';
lpParameters:= PChar('-REP -v -p 8192 -user SYSDBA -password "masterkey" "'+ (Label3.Caption+Edit3.Text)+'" "'+Edit1.Text+'"');
lpDirectory:=PChar(ExtractFilePath(Application.Name));
ShellExecute(Handle, lpOperation, lpFile, lpParameters, lpDirectory, SW_HIDE);
varbPasado:=true
finally
if varbPasado=true then ShowMessage('Proceso terminado')
else ShowMessage('El fichero ya existe');
Free;
end;
end;
end;
end.
y una imagen
Archivos adjuntos
-
4520_1a6596afaa64f6c6a1784118c9159ad25dac30c7.zip 920,38KB
16 descargas
Excelente aporte amigo. Muchas gracias.
