[[José Luis Garcí]]

Hola compañeros acabo de hacer una pequeña herramienta y me gustaría compartirla, para como siempre pretendo, si es útil, pues que sea usada, en caso contrario, pues omitirla, sobre todo me gustaría si descubren como mejorarla o si veis que esta mal, lo aportarais al club, dejo el ejecutable y los fuentes, tanto en código, como en archivos (en el FTP).

Código Delphi [-]
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.delphiaccess.com/forum/tr...eso-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