Delphi 2.0 - Programmer's Utilities Power Pack/Delphi 2.0 Programmer's Utilities Power Pack.iso/e_to_l/imlib201/tmulti.pas

Pascal/Delphi Source File | 1996-09-15 | 14.1 KB | 505 lines

{Copyright 1995 by
 Kevin Adams, 74742,1444
 Jan Dekkers, 72130,353

}

{Part of Imagelib VCL/DLL Library.

Written by Jan Dekkers and Kevin Adams}


unit TMulti;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls,
  extctrls, StdCtrls, DLL20LIN, menus, Mask, Buttons;


type
  TMultiImage = class(TGraphicControl)
  private
    FPicture            : TPicture;
    FAutoSize           : Boolean;
    FStretch            : Boolean;
    FCenter             : Boolean;
    FReserved           : Byte;
    FFilename           : TFileName;
    Fdither             : byte;
    FResolution         : byte;
    FSaveQuality        : byte;
    FSaveSmooth         : byte;
    FSaveFileName       : TFileName;
    Temps               : TFileName;
    function GetCanvas: TCanvas;
    procedure PictureChanged(Sender: TObject);
    procedure SetAutoSize(Value: Boolean);
    procedure SetCenter(Value: Boolean);
    procedure SetPicture(Value: TPicture);
    procedure SetStretch(Value: Boolean);
  protected
    function GetPalette: HPALETTE; override;
  public
    BFiletype           :  String;
    Bwidth              :  Integer;
    BHeight             :  Integer;
    Bbitspixel          :  Integer;
    Bplanes             :  Integer;
    Bnumcolors          :  Integer;
    BSize               :  Longint;
    Bcompression        :  String;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property Canvas: TCanvas read GetCanvas;
    function GetMultiBitmap : String;
    Procedure WriteMultiName(Name : String);
    procedure Paint; override;
    function GetSmooth : Byte;
    procedure SetSmooth(smooth : Byte);
    function GetQuality : Byte;
    procedure SetQuality(Quality : Byte);
    function GetDither : Byte;
    procedure SetDither(dith : Byte);
    function GetRes : Byte;
    procedure SetRes(res : Byte);
    function GetSaveFileName : TFilename;
    procedure SetSaveFileName(fn : TFilename);
    procedure SaveAsJpg(FN : TFileName);
    procedure SaveAsBMP(FN : TFileName);
    function GetInfoAndType(filename : TFilename) : Boolean;
  published
    property Align;
    property AutoSize: Boolean read FAutoSize write SetAutoSize default False;
    property Center: Boolean read FCenter write SetCenter default False;
    property DragCursor;
    property DragMode;
    property Enabled;
    property JPegDither : Byte read GetDither write SetDither;
    property JPegResolution : Byte read GetRes write SetRes;
    property Picture: TPicture read FPicture write SetPicture;
    property JPegSaveQuality : Byte read GetQuality write SetQuality;
    property JPegSaveSmooth : Byte read GetSmooth write SetSmooth;
    property DefSaveFileName : TFileName read GetSaveFileName write SetSaveFileName;
    property ImageName  : String read GetMultiBitmap write WriteMultiName;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Stretch: Boolean read FStretch write SetStretch default False;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;


var
 TMultiImageCallBack   : TCallBackFunction;
{------------------------------------------------------------------------}

implementation

  uses Consts, Clipbrd, Dialogs;


{------------------------------------------------------------------------
 TMultiImage.
------------------------------------------------------------------------}


constructor TMultiImage.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPicture := TPicture.Create;
  FPicture.OnChange := PictureChanged;
  FFilename:='';
  Fdither:=4;
  FResolution:=8;
  FSaveQuality:=25;
  FSaveSmooth:=0;
  Picture.Graphic := nil;
  Height := 105;
  Width := 105;
 end;
{------------------------------------------------------------------------}


destructor TMultiImage.Destroy;
begin
  FPicture.Free;
  inherited Destroy;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetPalette: HPALETTE;
begin
  Result := 0;
  if FPicture.Graphic is TBitmap then
    Result := TBitmap(FPicture.Graphic).Palette;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.Paint;
var
  Dest: TRect;
begin
  if csDesigning in ComponentState then
    with inherited Canvas do
    begin
      Pen.Style := psDash;
      Brush.Style := bsClear;
      Rectangle(0, 0, Width, Height);
    end;
  if Stretch then
    Dest := ClientRect
  else if Center then
    Dest := Bounds((Width - Picture.Width) div 2, (Height - Picture.Height) div 2,
      Picture.Width, Picture.Height)
  else
    Dest := Rect(0, 0, Picture.Width, Picture.Height);
  with inherited Canvas do
    StretchDraw(Dest, Picture.Graphic);
end;

{------------------------------------------------------------------------}

function TMultiImage.GetCanvas: TCanvas;
var
  Bitmap: TBitmap;
begin
  if Picture.Graphic = nil then
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := Width;
      Bitmap.Height := Height;
      Picture.Graphic := Bitmap;
    finally
      Bitmap.Free;
    end;
  end;
  if Picture.Graphic is TBitmap then
    Result := TBitmap(Picture.Graphic).Canvas
  else
    raise EInvalidOperation.Create(LoadStr(SImageCanvasNeedsBitmap));
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetAutoSize(Value: Boolean);
begin
  FAutoSize := Value;
  PictureChanged(Self);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetCenter(Value: Boolean);
begin
  if FCenter <> Value then
  begin
    FCenter := Value;
    Invalidate;
  end;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetPicture(Value: TPicture);
begin
  FPicture.Assign(Value);
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetStretch(Value: Boolean);
begin
  FStretch := Value;
  Invalidate;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.PictureChanged(Sender: TObject);
begin
  if AutoSize and (Picture.Width > 0) and (Picture.Height > 0) then
    SetBounds(Left, Top, Picture.Width, Picture.Height);
  if (Picture.Graphic is TBitmap) and (Picture.Width = Width) and
    (Picture.Height = Height) then
    ControlStyle := ControlStyle + [csOpaque] else
    ControlStyle := ControlStyle - [csOpaque];
  Invalidate;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetDither : Byte;
begin
  GetDither:=Fdither
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetDither(dith : Byte);
begin
  Fdither:=4;
  case dith of
            0..4 :Fdither:=dith;
  end;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetRes : Byte;
begin
  GetRes:=FResolution;
end;
{------------------------------------------------------------------------}


procedure TMultiImage.SetRes(res : Byte);
begin
  FResolution:=8;
  case res of
            4 :FResolution:=res;
            8 :FResolution:=res;
            24 :FResolution:=res;
  end;
end;
{------------------------------------------------------------------------}

Procedure TMultiImage.WriteMultiName(Name : String);
begin
  FFilename:=Name;
  GetMultiBitmap;
end;
{------------------------------------------------------------------------}


function TMultiImage.GetMultiBitmap :  String;
var    bitmap     : TBitMap;
       Pextension : string[4];
       OnExcept   : Boolean;
       f          : file of byte;
label  BreakIt;

begin
  OnExcept:=False;
  if not FileExists(FFilename) then begin
     Picture.Graphic := nil;
     temps:='file not found';
     GetMultiBitmap:=temps;
     exit;
  end;

  if FResolution <> 4 then if FResolution <> 8 then if FResolution <> 24 then
   FResolution:=8;

  if (FDither < 0) or (FDither > 4) then FDither:=4;

  Pextension:=UpperCase(ExtractFileExt(FFilename));

  if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
    Picture.LoadFromFile(FFilename);
    Temps:='Non JPeg, BMP, GIF or PCX Image';
    GetMultiBitmap:=Temps;
    GetInfoAndType(FFileName);
    exit;
  end;

 if (UpperCase(FFilename) = temps) and (Picture.Bitmap <> nil) then
   Goto BreakIt;

 if Pextension = '.BMP' then begin
    try
     Bitmap := TBitmap.Create;
     if not bmpfile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading bmp file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.GIF' then begin
    try
     Bitmap := TBitmap.Create;
     if not Giffile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading gif file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.PCX' then begin
    try
     Bitmap := TBitmap.Create;
     if not PCXfile(FFileName, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading pcx file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 if Pextension = '.JPG' then begin
    try
     Bitmap := TBitmap.Create;
     if not jpgfile(FFilename, FResolution, Fdither, Bitmap, TMultiImageCallBack) then
       MessageDlg('Reading jpg file failed', mtInformation, [mbOk], 0);
    except
     Picture.Graphic := nil;
     Bitmap.Free;
     OnExcept:=True;
    end;
     if OnExcept then Goto BreakIt;
     Picture.Graphic:=Bitmap;
     Bitmap.Free;
     GetInfoAndType(FFileName);
 end;

 BreakIt:
 Temps:=UpperCase(FFilename);
 GetMultiBitmap:=Temps;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetSmooth : Byte;
begin
  GetSmooth:=FSaveSmooth;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetSmooth(Smooth : Byte);
begin
  if (Smooth > 100) or (Smooth < 0) then FSaveSmooth:=5 else
   FSaveSmooth:=Smooth;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetQuality : Byte;
begin
  GetQuality:=FSaveQuality;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetQuality(Quality : Byte);
begin
  if (Quality > 100) OR (Quality < 1) then FSaveQuality:=25 else
   FSaveQuality:=Quality;
end;
{------------------------------------------------------------------------}

function TMultiImage.GetSaveFileName : TFilename;
begin
  GetSaveFileName:=FSaveFileName;
end;
{------------------------------------------------------------------------}

procedure TMultiImage.SetSaveFileName(fn : TFilename);
begin
 if fn <> '' then
   FSaveFileName:=fn
 else
   FSaveFileName:='';
end;


{------------------------------------------------------------------------}
procedure TMultiImage.SaveAsBMP(FN : TFileName);
begin
   if fn <> '' then FSaveFileName:=fn;
  try
    if not putbmpfile(FSaveFileName, picture.Bitmap, TMultiImageCallBack) then
      MessageDlg('Writing bmp file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

{------------------------------------------------------------------------}

procedure TMultiImage.SaveAsJpg(FN : TFileName);
begin
   if fn <> '' then FSaveFileName:=fn;
  try
   if not putjpgfile(FSaveFileName, FSaveQuality, FSaveSmooth, picture.Bitmap, TMultiImageCallBack) then
      MessageDlg('Writing jpg file failed', mtInformation, [mbOk], 0);
  except

  end;
end;

{------------------------------------------------------------------------}
function TMultiImage.GetInfoAndType(filename : TFilename) : Boolean;
var
  Pextension : string[4];
  f          : file of byte;
begin
  Pextension:=UpperCase(ExtractFileExt(Filename));
  if (Pextension =  '.WMF') or (Pextension =  '.ICO') then begin
   if fileexists(Filename) then begin
    Delete(Pextension,1,1);
    BFiletype           := Pextension;
    Bwidth              := Picture.width;
    BHeight             := Picture.Height;
    Bbitspixel          := 0;
    Bplanes             := 0;
    Bnumcolors          := 0;
    Bcompression        := Pextension;
    AssignFile(f, FFileName);
    Reset(f);
    Bsize := FileSize(f);
    CloseFile(f);
    GetInfoAndType:=true;
    exit;
   end else begin
    BFiletype           := 'ERR';
    Bwidth              := -1;
    BHeight             := -1;
    Bbitspixel          := -1;
    Bplanes             := -1;
    Bnumcolors          := -1;
    Bcompression        := 'ERR';
    Bsize               := -1;
    GetInfoAndType      := false;
    exit;
   end;
  end;
  GetInfoAndType:=GetFileInfo(filename,
                              BFileType,
                              Bwidth,
                              BHeight,
                              Bbitspixel,
                              Bplanes,
                              Bnumcolors,
                              Bcompression);
   AssignFile(f, FileName);
   Reset(f);
   Bsize := FileSize(f);
   CloseFile(f);
 end;

{------------------------------------------------------------------------
end TMultiImage
------------------------------------------------------------------------}

begin
 TMultiImageCallBack:=nil;
end.