compmain.pas

TCompress Component Set For Delphi Kylix BCB v9.0

(*
  CompDemo for TCompress Component Set

  See Thread-safe code example in CompressFilesViaThread

  You are free to amend, adjust, improve, update, borrow, alter and play
  with this demonstration program at will.

  However, if you redistribute the unregistered TCompress components, please be
  sure to include ALL the files that came with it (incl. Compress.hlp, Readme.txt
  and the ORIGINAL COMPDEMO source).  Thanks.

  Hint: To find the code which makes use of the TCompress components, search
  for Compress1, CDBImage1 and CDBMemo1 references...  At some point, you may
  also want to modify this demo to play with the Key, TargetPath and
  MakeDirectories properties of the TCompress component (all new in V2.5), or
  to experiment with the CompressStreamToArchive method (new in V3.0) of which
  a sample is given in SaveDirectToArchive.

  Enjoy.
*)

unit Compmain;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, DB, DBTables, DBCtrls, ExtCtrls, Buttons, FileCtrl, Mask,
  Compress, CompCtrl
{$IFDEF CLR}
  , System.ComponentModel, System.Threading
{$ENDIF}
  ;


type
  TForm1 = class(TForm)
    Panel2: TPanel;
    Shape1: TShape;
    DBText1: TDBText;
    Image1: TImage;
    Memo1: TMemo;
    Memo2: TMemo;
    DBNavigator1: TDBNavigator;
    CMethod: TRadioGroup;
    GroupBox1: TGroupBox;
    FL: TFileListBox;
    DL: TDirectoryListBox;
    DCB: TDriveComboBox;
    Memo3: TMemo;
    ArchiveGroup: TGroupBox;
    ArchiveLabel: TLabel;
    Label2: TLabel;
    archivefile: TEdit;
    ListBox1: TListBox;
    Memo4: TMemo;
    Fishname: TDBEdit;
    Memo5: TMemo;
    Memo6: TMemo;
    Button1: TButton;
    Panel1: TPanel;
    Bevel1: TBevel;
    Time: TLabel;
    Percentage: TLabel;
    TimeLabel: TLabel;
    Label7: TLabel;
    Trashcan: TImage;
    Button2: TButton;
    CDBImage1: TCDBImage;
    CDBMemo1: TCDBMemo;
    Button3: TButton;
    Table1: TTable;
    Table1SpeciesNo: TFloatField;
    Table1Category: TStringField;
    Table1Common_Name: TStringField;
    Table1SpeciesName: TStringField;
    Table1Lengthcm: TFloatField;
    Table1Length_In: TFloatField;
    CDBImage1Graphic: TCGraphicField;
    CDBMemo1Notes: TCMemoField;
    DataSource1: TDataSource;
    Compress1: TCompress;
    procedure CompressOneFile(var fname: String);
    procedure ResetFileInfo;
    function GetDir: string;
    function GetDummyFilename(generatefrom: string; ext: string): string;
    procedure handleDropField(Source: TObject; archivetoo: Boolean);
    procedure SaveDirectToArchive(Source: TField; filename: string);
    procedure CompressFiles;
    function getCompressionMethod: TCompressionMethod;
    procedure showInfo(comp: TCompress);
    procedure FormCreate(Sender: TObject);
    procedure showfiles;
    procedure ExpandDelete(Operation: TCProcessMode; All: Boolean);
    procedure archivefileChange(Sender: TObject);
    procedure CMethodClick(Sender: TObject);
    procedure DLDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure CDBImage1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure CDBImage1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure CDBMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure CDBMemo1DragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure CDBImage1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure CDBMemo1MouseDown(Sender: TObject; Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer);
    procedure archivefileDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure archivefileDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure DLDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure TrashcanDragDrop(Sender, Source: TObject; X, Y: Integer);
    procedure FormDestroy(Sender: TObject);
    procedure ListBox1Click(Sender: TObject);
    procedure Table1AfterPost(DataSet: TDataset);
    procedure Button1Click(Sender: TObject);
    procedure FLClick(Sender: TObject);
    procedure Compress1CheckFile(var filepath: String;
      mode: TCProcessMode);
    procedure Panel1Click(Sender: TObject);
    procedure FormClick(Sender: TObject);
    procedure GroupBox1Click(Sender: TObject);
    procedure TrashcanDragOver(Sender, Source: TObject; X, Y: Integer;
      State: TDragState; var Accept: Boolean);
    procedure Button2Click(Sender: TObject);
    procedure Compress1ShowProgress(var PercentageDone: Longint);
    procedure Button3Click(Sender: TObject);
    procedure disabledragMode;
    procedure enabledragMode;
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation

{$R *.NFM}

var FileList: TStringList; { holds information about our archive files }
    saveCompressionMethod: Integer; { see ListBox1.click }

const ShowFileInfoColor :Tcolor = clGray; { see Listbox1.click }

{ Example of accessing the TCompress performance properties }
procedure Tform1.showinfo(comp: TCompress);
begin
   ResetFileInfo;
   Time.caption:=Format('%-5.1fsecs',[Comp.CompressionTime/1000.0]{[f]});
   Percentage.caption:=IntToStr(Comp.CompressedPercentage)+'%';
end;

{ Example of a progress event (new in TCompress 2.0) }
procedure TForm1.Compress1ShowProgress(var PercentageDone: Longint);
begin
   Percentage.caption:=IntToStr(PercentageDone)+'%';
   Application.ProcessMessages;
  { you may have *other* uses for this every-8K-read event...  In fact, in V2.5
    if you set PercentageDone to -1, it will cause compression to end at the
    point reached. If so, delete from the archive the compressed file
    which was created before the abort  }
end;

{ Example of getting a list of files in a multi-file archive }
procedure TForm1.showfiles;
begin
  listbox1.clear;
  Compress1.FreeFileList(FileList); { clear list and free any file information objects in it }
  if not FileExists(archivefile.Text) then exit;
  Compress1.ScanCompressedFile(ArchiveFile.Text,Filelist);
  ListBox1.Items.addStrings(FileList); { and File info objects are
                            there too -- see ListBox1Click and FormDestroy }
end;

{ Example of expanding/deleting one or more files from a multi-file archive }
procedure TForm1.ExpandDelete(Operation: TCProcessMode; All: Boolean);
var s: Tstringlist;
  count: Integer;
begin
  if (All and (Listbox1.Items.count > 0)) or (Listbox1.selcount>0) then { something is... }
  begin
     s:=Tstringlist.create;
     try
        if All then
           s.addStrings(ListBox1.Items)
        else
           for count :=0 to Listbox1.ITems.count-1 do
            if Listbox1.selected[count] then
              s.add(Listbox1.items[count]);
        if Operation=cmExpand then { expand }
          compress1.expandfiles(ArchiveFile.Text,s)
        else
          compress1.deletefiles(ArchiveFile.Text,s);
        showinfo(Compress1);
        showfiles; { also clears selections... }
     finally
        s.free;
        Screen.Cursor := crDefault;
     end;
  end;
end;

{ Example of compressing a SINGLE file into an archive }
procedure TForm1.CompressOneFile(var fname: String);
begin
  disableDragMode;
  try
    Compress1.CompressFile(ArchiveFile.Text,fname,getCompressionMethod);
    showInfo(Compress1);
    showfiles;
  finally
    Screen.Cursor := crDefault;
    enableDragMode;
  end;
  SysUtils.DeleteFile(fname); { because for this example we're creating TEMP files only... }
end;


{ Example of compressing MULTIPLE files into an archive }
{ V4.0: For CompressFiles(only) we're also showing how
  to create a thread (and a new instance of the component) to do the
  addition.
}

procedure CompressFilesViaThread;
var s: Tstringlist;
    Count: Integer;
    tc: TCompress;
begin
  with Form1 do
  if FL.selcount>0 then { something is... }
  begin
    s:=TStringlist.Create;
    try
      disableDragMode;
      for count :=0 to FL.Items.count-1 do
        if FL.selected[count] then
          s.add(FL.items[count]);
       tc := TCompress.create(nil);
       with tc do
       begin
         RegName := Compress1.RegName; { in case you've set these }
         RegNumber := Compress1.RegNumber;
         Key := Compress1.Key;
         OnShowProgress := Compress1.OnShowProgress;
         CompressFiles(ArchiveFile.Text,s,getCompressionMethod);
         showInfo(tc);
         free;
       end;
       showfiles;
    finally;
       s.free;
       Screen.Cursor := crDefault;
       enableDragMode;
    end;
  end;
end;

procedure TForm1.CompressFiles;
var
{$IFDEF CLR}
  aThread: System.Threading.Thread;
{$ELSE}
  threadid: Cardinal;
{$ENDIF}
begin
{$IFDEF CLR}
  aThread := System.Threading.Thread.Create(CompressFilesViaThread);
  aThread.Start;
{$ELSE}
  IsMultiThread := true;
  CreateThread(nil, 8192, @CompressFilesViaThread, nil, 0, threadID);
{$ENDIF}
end;

{ Examples of setting/loading/shifting image blobs }
procedure TForm1.CDBImage1DragDrop(Sender, Source: TObject; X, Y: Integer);
var filepath: String;
    isCenterImage: Boolean;
begin
   if Source=Sender then exit; { nowt to do }
   isCenterImage := (Sender=Image1) or (Sender=Memo1);
   if (Sender is TCDBImage) and (not Table1.active) then
   begin
     showmessage('Can''t do this unless table has been opened...');
     exit;
   end;

  Screen.Cursor:= crHourGlass;
  if (Source = Image1) and (Sender is TCDBImage) then
  begin
     Table1.edit;
     CDBImage1.picture.bitmap.Assign(Image1.Picture.bitmap)
  end
  else if (Source is TCDBImage) and isCenterImage then
     Image1.picture.bitmap.Assign(CDBImage1.Picture.Bitmap)
  else
  begin   { Have we got an image? }
     filepath := '';
     if (Source is TListBox) and (Listbox1.selcount = 1) then
      filepath:=ListBox1.Items[Listbox1.ItemIndex] { archive list }
     else if (Source is TFileListBox) and (FL.selcount=1) then
        filepath:=FL.Items[FL.ItemIndex]; { file list }
     if LowerCase(ExtractFileExt(filepath))<>'.bmp' then
     begin
        MessageBeep(1);
        showmessage('Must be a .BMP file...')
     end else begin                             { ok, here we go... }
        if Source is TListBox then { must first extract file... }
        begin { Note: see ARC2BLOB.PAS and ARC2MEM.PAS for three FASTER ways
                        of going about this (no expanded file needed) }
          try
            Compress1.ExpandFile(filepath,ArchiveFile.Text);
          finally
            Screen.cursor := crDefault; { as our OnCheckFile sets it on }
          end;
          if filepath='' then exit; { was skipped on confirmation }
        end;
        Screen.Cursor:= crHourGlass;
        if isCenterImage then
           Image1.Picture.Bitmap.LoadFromfile(filepath)
        else begin
           Table1.edit;
           CDBImage1.Picture.Bitmap.LoadFromFile(filepath);
        end
     end; { else }
  end;
  if not Image1.Picture.Bitmap.Empty then
  begin
   Memo1.visible := False; { got a piccy showing... }
   image1.visible := True;
  end;
  Screen.Cursor:= crDefault;
end;

{ Examples of setting/loading/shifting CDBMemo blobs }
procedure TForm1.CDBMemo1DragDrop(Sender, Source: TObject; X, Y: Integer);
var filepath: String;
begin
  if Source=Sender then exit; { nowt to do }
  filepath := ''; { in case fails }
  if (Source is TListBox) and (Listbox1.selcount = 1) then
   filepath:=ListBox1.Items[Listbox1.ItemIndex] { archive list }
  else if (Source is TFileListBox) and (FL.selcount=1) then
     filepath:=FL.Items[FL.ItemIndex]; { file list }
  if LowerCase(ExtractFileExt(filepath))<>'.txt' then
  begin
    MessageBeep(1);
    showmessage('Must be a .TXT file...')
  end else begin                             { ok, here we go... }
    if Source is TListBox then { must first extract file... }
    begin { Note: see ARC2BLOB.PAS and ARC2MEM.PAS for three FASTER ways
                       of going about this (no expanded file needed) }
      try
        Compress1.ExpandFile(filepath,ArchiveFile.Text);
      finally
        Screen.cursor := crDefault; { as our OnCheckFile sets it on }
      end;
      if filepath='' then exit; { was skipped on confirmation }
    end;
    Screen.Cursor:= crHourGlass;
    Table1.edit;
    CDBMemo1.Lines.LoadfromFile(filepath)
  end;
  Screen.Cursor:= crDefault;
end;

procedure TForm1.CDBMemo1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  accept := (Source is TFileListBox) or (Source is TListBox) or (Source is TCDBMemo);
end;

procedure TForm1.CDBImage1DragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  accept := (Source=Image1) or (Source is TCDBImage) or
     (Source is TFileListBox) or (Source is TListBox);
end;

{ Refreshing a CDBImage so it will be compressed (assuming previously uncompressed) }
procedure TForm1.CDBImage1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button=mbRight then { ok, refresh our field }
  begin
     CDBImage1.CopyToClipBoard;
     CDBImage1.PasteFromClipBoard;
     Table1.post;
  end;
end;

procedure TForm1.CDBMemo1MouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  if Button=mbRight then { ok, refresh our field }
  begin
     CDBMemo1.Lines[0]:=CDBMemo1.Lines[0]; { setting .Modified doesn't do it... }
     Table1.post;
  end;

end;