Отправлено =AK= 17 января 2005 г. 14:25 В ответ на: Есть такое дело... отправлено =AK= 17 января 2005 г. 13:41

{ Unit:           Main.pas - GUI procedures
}
//---------------------------------------------------------------------
{
  BMPcompress allows to compress B/W bitmaps. It uses RLE compression
  algorithm described in http://groups.google.com/groups?hl=ru&lr=&threadm=bo23jo%24163%241145%40www.fido-online.com&rnum=1&prev=/groups%3Fq%3DAlex%2BKouznetsov%26hl%3Dru%26lr%3D%26group%3Dfido7.ru.compress%26selm%3Dbo23jo%2524163%25241145%2540www.fido-online.com%26rnum%3D1
  It is possible to start the program from command line. Syntax is:
  BMPcompress  
  Default output file extension is .bmc 
  Data are stored as raw ascii hex. First 8 bytes is a bitmap header }
unit Main;
// *********************************************
                interface
// *********************************************
uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Menus, ExtCtrls, ExtDlgs, ComCtrls, StdCtrls, Compressor;
type
  TForm1 = class(TForm)
    MainMenu1: TMainMenu;
    File1: TMenuItem;
    Open1: TMenuItem;
    SaveCompressed1: TMenuItem;
    N1: TMenuItem;
    Exit1: TMenuItem;
    OpenPictureDialog1: TOpenPictureDialog;
    GroupBox1: TGroupBox;
    StatusBar1: TStatusBar;
    About1: TMenuItem;
    Image1: TImage;
    SaveAs1: TMenuItem;
    SaveDialog1: TSaveDialog;
    procedure Exit1Click(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure Open1Click(Sender: TObject);
    procedure About1Click(Sender: TObject);
    procedure SaveCompressed1Click(Sender: TObject);
    procedure Image1DblClick(Sender: TObject);
    procedure SaveAs1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
    FCurrentPath:string;
  end;
procedure LoadAndCompress;
procedure SaveCompressed;
var
  Form1: TForm1;
// *********************************************
                implementation
// *********************************************
var
  src_fn, dst_fn:string;
  f:textfile;
{$R *.DFM}
// ---------------------------------------------------------------
procedure TForm1.FormCreate(Sender: TObject);
begin
  FCurrentPath:=ExtractFilePath(Application.ExeName);
  OpenPictureDialog1.InitialDir:=FCurrentPath;
  src_fn:=''; dst_fn:='';
  if ParamCount>0 then
    src_fn:=ParamStr(1);
  if ParamCount>1 then
    dst_fn:=ParamStr(2);
  if (src_fn<>'') and (dst_fn<>'') then begin
    if FileExists(src_fn) then begin
      LoadAndCompress;
      SaveCompressed;
    end else
      MessageDlg('Cannot find file '+src_fn,mtError,[mbOK],0);
    Exit1Click(Sender);
  end;
end;
// ---------------------------------------------------------------
procedure TForm1.Exit1Click(Sender: TObject);
begin
  Application.Terminate;
end;
// ---------------------------------------------------------------
procedure TForm1.About1Click(Sender: TObject);
begin
  MessageDlg('Bitmap Compressor Rev 1.1, =AK=', MTInformation,[mbOK],0);
end;
// ---------------------------------------------------------------
procedure LoadAndCompress;
var
    bytewidth, bufsize:integer;
    r:real;
begin
  with Form1 do begin
      // -----------
      // read bitmap
      // -----------
      Image1.Picture.LoadFromFile(src_fn);
      Image1.Picture.Bitmap.Monochrome:=true;
      Image1.Picture.Bitmap.PixelFormat:=pf1bit;
      // -----------
      // compress
      // -----------
      Compr.AutoCompress(false);
  end;
end;
// ---------------------------------------------------------------
procedure TForm1.Open1Click(Sender: TObject);
var s:string;
begin
  try
    if OpenPictureDialog1.execute then begin
      src_fn:=OpenPictureDialog1.FileName;
      OpenPictureDialog1.InitialDir:=ExtractFilePath(src_fn);
      LoadAndCompress;
      // ---------------------
      // prepare status string
      // ---------------------
      s:=OpenPictureDialog1.FileName;
      src_fn:=ExtractFileName(s);
      dst_fn:=ChangeFileExt(s, '.bmc');
      GroupBox1.Caption:=src_fn;
      s:='Bitmap: ';
      s:=s+IntToStr(Image1.Picture.Width)+'x'+IntToStr(Image1.Picture.Height);
      s := s+'   Data: '+IntToStr(Compr.InStream.Len);
      if Compr.Compressed then begin
        s:=s+' / '+IntToStr(Compr.OutStream.Len);
      end;
      s:=s+' bytes';
      s:=s+'   Compression: '+FloatToStrF(Compr.CompressionRatio,ffFixed,5,2)+'   ';
      if Compr.Compressed then begin
        if Compr.DoubleBuffer then
          s:=s+'(double buffer)'
        else
          s:=s+'(single buffer)';
      end else
         s:=s+'(not compressed)';
      // ---------------
      // display status
      // ---------------
      StatusBar1.SimpleText :=s;
    end;
  except
    MessageDlg('Cannot recognise file format',mtError,[mbCancel],0);
  end;
end;
// ---------------------------------------------------------------
procedure SaveCompressed;
var i,cnt,len:integer;
    s:string;
begin
      AssignFile(f,dst_fn);
      Rewrite(f);
      // comment
      Writeln(f,'; '+ExtractFileName(dst_fn));
      s:='; Bitmap '+IntToStr(Compr.BmpWidth)+'x'+IntToStr(Compr.BmpHeight);
      if not Compr.Compressed then
        s:=s+' not compressed'
      else
        s:=s+' compressed '+FloatToStrF(Compr.CompressionRatio,ffFixed,5,2)+' times';
      Writeln(f,s);
      // File format
      if not Compr.Compressed then
        s:='00 '
      else begin
        if Compr.DoubleBuffer then
          s:='02 '
        else
          s:='01 ';
      end;
      // data length
      if Compr.Compressed then begin
        s:=s+ByteToHexStr(Hi(Compr.OutStream.Len))+' ';
        s:=s+ByteToHexStr(Lo(Compr.OutStream.Len))+' ';
      end else begin
        s:=s+ByteToHexStr(Hi(Compr.InStream.Len))+' ';
        s:=s+ByteToHexStr(Lo(Compr.InStream.Len))+' ';
      end;
      // bitmap width and height
      s:=s+ByteToHexStr(Hi(Compr.BmpWidth))+' ';
      s:=s+ByteToHexStr(Lo(Compr.BmpWidth))+' ';
      s:=s+ByteToHexStr(Hi(Compr.BmpHeight))+' ';
      s:=s+ByteToHexStr(Lo(Compr.BmpHeight))+' ';
      s:=s+'00'; // reserved byte
      Writeln(f,s);
      if Compr.Compressed then
        len:=Compr.OutStream.Len
      else
        len:=Compr.InStream.Len;
      i:=0;
      while i        cnt:=0;  s:='';
        while cnt<16 do begin
          if Compr.Compressed then begin
             s:=s+ByteToHexStr(not Compr.OutStream.Dat[i])+' ';
            inc(cnt); inc(i);
            if (i>=Compr.OutStream.Len) then break;
          end else begin
             s:=s+ByteToHexStr(not Compr.InStream.Dat[i])+' ';
            inc(cnt); inc(i);
            if (i>=Compr.InStream.Len) then break;
          end;
        end;
        Writeln(f,s);
      end;
      CloseFile(f);
end;
// ---------------------------------------------------------------
procedure TForm1.SaveCompressed1Click(Sender: TObject);
begin
  if  src_fn='' then
    MessageDlg('There is no bitmap to save',mtError,[mbOK],0)
  else begin
    if mrOK=MessageDlg('Save as  '+ExtractFileName(dst_fn)+'?',
    mtConfirmation,[mbOK,mbAbort],0) then
      SaveCompressed;
  end;
end;
// ---------------------------------------------------------------
procedure TForm1.Image1DblClick(Sender: TObject);
begin
    Compr.AutoCompress(true);
    Image1.Invalidate;
end;
// ---------------------------------------------------------------
procedure TForm1.SaveAs1Click(Sender: TObject);
begin
  if SaveDialog1.Execute then begin
    if  src_fn='' then
      MessageDlg('There is no bitmap to save',mtError,[mbOK],0)
    else begin
      if mrOK=MessageDlg('Save as  '+ExtractFileName(dst_fn)+'?',
      mtConfirmation,[mbOK,mbAbort],0) then
        SaveCompressed;
    end;
  end;
end;
end.