compmain.pas

TCompress Component Set For Delphi Kylix BCB v9.0

procedure TForm1.CMethodClick(Sender: TObject);
begin
  CDBIMage1.CompressionMethod := getCompressionMethod;
  CDBMemo1.CompressionMethod := getCompressionMethod;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
 Application.HelpFile:='COMPRESS.HLP';
 fileList := TStringList.create; { keeps track of our archive files for display etc. }
 SendMessage(ListBox1.handle,LB_SetHorizontalExtent,300,LongInt(0));
 saveCompressionMethod := -1; { see Listbox1.click }
 showfiles; { show files in archive (if any)... }
{$IFNDEF CLR}
 try
 {$IFDEF VER140}
   DL.Directory := '\Program Files\Borland\Delphi6\IMAGES\BACKGRND';
 {$ENDIF}
 {$IFDEF VER150}
   DL.Directory := '\Program Files\Borland\Delphi7\IMAGES\BACKGRND';
 {$ENDIF}
 except on EInOutError do ; { nowt, let it default }
 end;
{$ENDIF}

 try Table1.Active := True;
     DataSource1.Edit;
 except
  on EDBEngineError do
     showmessage('The BLOB compression portion of this demonstration'+#13+
                 'requires that the DBDEMOS alias be set up and pointing'+#13+
                 'to the BIOLIFE.DB table in \DELPHI\DEMOS\DATA.'+#13+#13+
                 '-- as this is not currently the case, the BLOB demonstration'+#13+
                 'is disabled.');
  on EUnrecognizedCompressionMethod do
     showmessage('Your BIOLIFE database appears to have been compressed with'+#13+
                 'a custom compression method which cannot be recognised.'+#13+
                 'Please revert to an uncompressed backup of BIOLIFE.*');
 end; {try }

 if not Table1.Active then { something went wrong... }
 begin
     CDBImage1.visible:=False;
     CDBMemo1.visible:=False;
     DBNavigator1.visible:=False;
     Memo1.visible:=False;
     Memo2.visible := True;
 end;
 CMethodClick(self);  { get default compression for our database controls }

end;

function TForm1.GetDir: string; { called below and in GetDummyFileName }
begin
  Result := DL.Directory;
  if Copy(Result,Length(Result),1)<>'\' then { not already \'d? }
    Result := Result+'\';
end;

procedure TForm1.archivefileChange(Sender: TObject);
begin
  showfiles;
end;

function TForm1.getCompressionMethod: TCompressionMethod;
begin
   result := coNone; { default }
   case CMethod.ItemIndex of
     1: result := coRLE;
     2: result := coLZH;
     3: result := coLZH5;
   end;
end;

procedure TForm1.DLDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  accept := True;
  if ((Sender is TDirectoryListBox) and (Source is TFileListBox)) or
     (Source=Trashcan) then
        accept := False; { fair enough? }
end;

procedure TForm1.archivefileDragOver(Sender, Source: TObject; X,
  Y: Integer; State: TDragState; var Accept: Boolean);
begin
  accept := True; { but... }
  if ((Source is TGroupBox) and not (Sender is TGroupBox)) or
         (((Sender is TEdit)or (Sender is TGroupBox)) and (Source is TListBox)) or { not from our OWN list }
           (Source=Trashcan) then
     accept := False;
end;

{ Used to create 'work' filenames for saving images and memos
  from the database into our archive or to disk... }
function TForm1.GetDummyFilename(generatefrom: string; ext: string): string;
begin
  if (generatefrom='Image') or (generateFrom='') then
     generatefrom:='image';
  result := Getdir+generatefrom+'.'+ext;
end;

function Confirmfilename(filename: String; archiving: Boolean): Boolean;
begin
  Result := True; { default for archiving }
  if (not Archiving) and
     (MessageDlg('Save to '+filename+'?', mtConfirmation,[mbYes, mbNo], 0)<>id_Yes) then
     Result := False;
end;

{ The handler for dropping things on the file list or archive list }
procedure TForm1.handleDropField(Source: TObject; archivetoo: Boolean);
var filename: String;
begin
  filename := ''; { in case it is NOT one of those below... }
  if Source is TCDBMemo then
  begin
     filename := GetDummyFilename(Fishname.Text,'TXT');
     if not confirmFilename(filename,archivetoo) then exit;
     if ArchiveToo then { V3.0 -- save directly into archive -- no temp file }
     begin
       SaveDirectToArchive((Source as TCDBMemo).Field,filename);
       exit;
     end else
       CDBMemo1.Lines.SaveToFile(filename); { save to directory }
  end else if Source is TCDBImage then
  begin
     filename := GetDummyFilename(Fishname.Text,'BMP');
     if not confirmFilename(filename,Archivetoo) then exit;
     if ArchiveToo then { V3.0 -- save directly into archive -- no temp file }
     begin
       SaveDirectToArchive((Source as TCDBImage).Field,filename);
       exit;
     end else
        CDBImage1.Picture.Bitmap.SaveToFile(filename); { save to directory }
  end
  else
   if Source = Image1 then
  begin
     filename := GetDummyFilename('Image','BMP');
     if not confirmFilename(filename,Archivetoo) then exit;
     Image1.Picture.Bitmap.SaveToFile(filename);
  end;
  if (filename<>'') and (ArchiveToo) then
      CompressOneFile(filename);
end;

{ new in V3.0, this routine APPENDS a blob to the archive, after first making
  sure something of the same name is not already there. While this is fast,
  in a working situation it would be tidier with a DeleteFiles call to remove
  any prior copy of the blob first...
}
procedure TForm1.SaveDirectToArchive(Source: TField; filename: string);
var bs: TCBlobstream; { for compressing into the archive: may need to auto-EXPAND first, hence TCBlobstream... }
begin
  filename :=ExtractFileName(filename);
  if FileList.Indexof(filename) >=0 then
  begin
    showmessage(filename+' is already in the archive -- please delete it first');
    exit; { to automate the deletion, we could just use the Compress1.DeleteFiles method }
  end;
  bs := TCBlobstream.Create(Source as TCBlobField,bmRead); { we're going to read the (expanded) field contents) }
  try
     if Source is TCGraphicField then { sorry about this, but we have to skip a graphic header which Delphi stores }
        bs.seek(8,soFromBeginning);  { in blob bitmaps, but which DON'T belong in BMP files -- this very hardwired
                                     code assumes it is there, and skips it }

     Screen.cursor := crHourGlass;
     disableDragMode;
     Compress1.CompressStreamToArchive(ArchiveFile.Text,bs, { and append/compress them to the archive... }
                                      filename,getCompressionMethod);
  finally
     enableDragMode;
     Screen.cursor := crDefault;
     bs.free;
  end;
  showinfo(Compress1);
  showfiles;
end;

procedure TForm1.archivefileDragDrop(Sender, Source: TObject; X,
  Y: Integer);
begin
  if Source is TFileListBox then
     CompressFiles
  else
    HandleDropField(Source, True); { save to temp file AND archive... }
end;

procedure TForm1.DLDragDrop(Sender, Source: TObject; X, Y: Integer);
begin
  if Source=Sender then exit; { seems reasonable, and IS necessary }
  if Source is TListBox then
    ExpandDelete(cmExpand,False) { selected archive files }
  else if Source=ArchiveGroup then
     ExpandDelete(cmExpand,True) { all archived files }
  else
    HandleDropField(Source, False); { save field to a file }
  FL.Update; { get up to date... }
end;
procedure TForm1.TrashcanDragDrop(Sender, Source: TObject; X, Y: Integer);
var count: Integer;
    tempBitmap: TBitMap; { just to get an empty one }
begin
  if Source is TListBox then
    ExpandDelete(cmDelete,False)
  else if Source=ArchiveGroup then
     ExpandDelete(cmDelete,True) { all files }
     { and strictly speaking, should now delete the archive if it is
       empty, but I'll leave that as an exercise... }
  else if Source is TFileListBox then { delete some or all... }
  begin
     for count:=0 to FL.Items.count-1 do
        if FL.selected[count] and
           (MessageDlg('Delete '+GetDir+FL.Items[count],mtConfirmation,[mbYes,mbNo],0)=id_Yes) then
           SysUtils.DeleteFile(GetDir+FL.Items[count]);
     FL.Update;
  end
  else if (Source is TCDBMemo) and
              (MessageDlg('Cut to clipboard?',mtConfirmation,[mbYes,mbNo],0)=id_Yes) then
  begin
     CDBMemo1.SelectAll;
     CDBMemo1.cutToClipboard { safer than .clear, for demo purposes }
  end
  else if (Source is TCDBImage) and
            (MessageDlg('Cut to clipboard?',mtConfirmation,[mbYes,mbNo],0)=id_Yes) then
      CDBImage1.cutToClipboard { not quite a delete, but just for example... }
  else if Source=Image1 then
  begin
     tempBitMap := TBitMap.Create;
     try
        Image1.Picture.Bitmap.Assign(tempBitMap);
        Image1.visible := False;
        Memo1.visible := True
     finally
        tempBitMap.free;
     end;
  end;


end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  Compress1.FreeFileList(FileList); { free list and any file information objects in it }
  FileList.free;
end;


procedure TForm1.ListBox1Click(Sender: TObject);
var cfinfo: TCompressedFileInfo;
    compmethod, percentageval: Integer;
begin
  if listBox1.ItemIndex >=0 then
  begin
     CMethod.Color := ShowFileInfoColor; { make it clear we are showing off a bit... }
     Percentage.Color := ShowFileInfoColor;
     Time.Color := ShowFileInfoColor;
     TimeLabel.Caption := 'Full Size:';

     cfinfo:=TCompressedFileinfo(FileList.objects[listBox1.ItemIndex]); { how to get at the other stuff... }
     if cfinfo.Fullsize>0 then
     begin
       if cfinfo.Fullsize>100000 then { makes safe for files >20Mb actually }
         Percentageval := cfinfo.CompressedSize div (cfinfo.Fullsize div 100)
       else
         Percentageval := 100*cfinfo.CompressedSize div cfinfo.Fullsize;
       Percentage.caption:=IntToStr(100-percentageval)+'%'
     end else
       Percentage.caption:='(empty)';
     if cfinfo.locked then
        Percentage.caption := Percentage.caption + ' (locked)';
     Time.caption:= IntToStr((512+cfinfo.Fullsize) div 1024)+' Kb';
     if saveCompressionMethod <0 then
        savecompressionMethod :=cMethod.ItemIndex;
     compMethod :=Integer(cfinfo.CompressedMode);
     if compMethod = 4 then
         compMethod := 3; { force LZH5 to show up as the third box }
     cMethod.ItemIndex :=compMethod;
  end;
end;

procedure TForm1.ResetFileInfo;
begin
  if saveCompressionMethod <0 then exit;
  cMethod.ItemIndex:=savecompressionMethod;
  saveCompressionMethod := -1;
  CMethod.Color := clBtnFace;
  Percentage.Color := clWindow;
  Time.Color := clWindow;
  TimeLabel.Caption := 'Time:';
  showInfo(Compress1); { get the right stuff too... }
  Time.Caption:=''; { but this is meaningless at this point... }
end;


procedure TForm1.Table1AfterPost(DataSet: TDataset);
begin
  Showinfo(Compress1);
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  ShowMessage('Drag && Drop at will: compression/expansion'+#13+
  'is automatic.'+#13+#13+
  'Uses TCompress, TCDBMemo and TCDBImage.'+#13+#13+
  'Component Registration and License: $US79'+#13+
  'See registration form in Help or:'+#13+
  'Fax [phone]   Email: [e-mail]');
end;

procedure TForm1.FLClick(Sender: TObject);
begin
  ResetFileInfo;
end;

{ Example of OnCheckFile user interface handling routine
  Note that the V2.5 TargetPath property frequently obviates the need
  for any Expand handler, but we've kept it anyway for your
  info. Also, you could Set the MakeDirectories property if
  the target path's should be created if required.
}
procedure TForm1.Compress1CheckFile(var filepath: String;
  mode: TCProcessMode);
var modestr: String;
  dlg: Integer;
begin
  case mode of
     cmExpand: begin
                 modestr := 'Expand';
                 filepath:=Getdir+extractfilename(filepath); { go where we should }
               end;
     cmCompress: begin
                    modestr := 'Compress';
                    filepath:={Getdir+}extractfilename(filepath); { use GetDir if you want full path... }
                 end;
     cmDelete: modestr := 'Delete';
  end;
  showInfo(Compress1);
  Screen.cursor := crDefault; { in case this is second call in a sequence }
  dlg := MessageDlg(modestr+' '+filepath+'?', mtConfirmation,[mbYes, mbNo, mbCancel], 0);
  case dlg of
     id_No: filepath :=CompressSkipFlag; { flag 'not this one'}
     id_Cancel: filepath :=CompressNoMoreFlag; { flag 'no more!' }
     id_Yes: Screen.Cursor := crHourGlass; { for operation itself }
  end;
end;


procedure TForm1.Panel1Click(Sender: TObject);
begin
ResetFileInfo;
end;

procedure TForm1.FormClick(Sender: TObject);
begin
ResetFileInfo;
end;

procedure TForm1.GroupBox1Click(Sender: TObject);
begin
ResetFileInfo;
end;

procedure TForm1.TrashcanDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
  accept := True;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
Application.HelpJump('1050');
end;

procedure TForm1.Button3Click(Sender: TObject);
begin
Application.HelpJump('1030');
end;

{ V3.03 -- disable dragging temporarily while compression
  is in progress, because otherwise it is *possible* (tho unlikely)
  to request a second compression before the first has finished,
  i.e. code is made non-re-entrant via the user interface.
  Not a problem with threads, just the fact that trying
  to add two files to the same archive at the same time is bad karma!
}
procedure TForm1.disableDragMode;
begin
  Fl.dragMode := dmManual;
  CDBMemo1.dragMode := dmManual;
  CDBImage1.dragMode := dmManual;
  ArchiveGroup.dragMode := dmManual;
  ListBox1.dragMode := dmManual;
end;

procedure TForm1.enableDragMode;
begin
  Fl.dragMode := dmAutomatic;
  CDBMemo1.dragMode := dmAutomatic;
  CDBImage1.dragMode := dmAutomatic;
  ArchiveGroup.dragMode := dmAutomatic;
  ListBox1.dragMode := dmAutomatic;
end;

end.