Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/simage/simage.pas

Pascal/Delphi Source File | 1995-12-22 | 18.5 KB | 637 lines

{Donated to the public domain 1-May-95 by Paul Peterson, Summit Software, Inc.}
{Please report any problems to 72371,1136 via CIS Mail)
{This component makes it much easer to display 256 color BMP files in
 Delphi. It will scale the image (or a rectangle of the image) up or down to
 best fit into the designed size of the component. It includes a cropping
 tool that a user can use at run-time to frame the part of the image of
 interest. See the BMPView demo app for how this component is used.  The
 'ChangeFromFile() method is the main way to control this component}
unit Simage;
interface
uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Forms, Controls,
  extctrls, StdCtrls;

Type
  TCropHandle = (NoHandle,INNER,UR,UL,BR,BL,LS,RS,TS,BS);
Const
  Yes = True;
  No  = False;
type
  TSimage = class(TImage)
    procedure loaded; override;
    constructor create(AOwner : Tcomponent); override;
    destructor Destroy; override;
    procedure MouseMove(
                     Shift : TShiftState;
                      X, Y : Integer); override;
    procedure click; override;
    procedure SizeAndShow;
    procedure HideNow;
    procedure ChangeFromFile(
            const FileName : string;
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
    procedure ReplaceWith(
                 fromImage : TSimage;
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
    procedure ReDraw(
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
    function get_filename : string;
    function get_rect : Trect;
    procedure SetDesignedSize(
                         t : integer;
                         l : integer;
                         w : integer;
                         h : integer);
    procedure GetDesignedSize(
                     Var t : integer;
                     Var l : integer;
                     Var w : integer;
                     Var h : integer);
    procedure draw_croptool(
                      Crop : Trect);
    procedure croptool_off(
               var changed : boolean;
                  var Crop : Trect);
    procedure croptool_on;
  public
    OrigPict : TPicture;
    curfilename    : string;
  private
    procedure erasecrop;
    function validcrop(
                  var rect : Trect;
                  var pict : Tpicture
                         ) : boolean;
  private
    oldx,
    oldy           : integer;
    DesignedTop,
    DesignedLeft,
    DesignedWidth,
    DesignedHeight : integer;
    CropRectActual,
    CropRectScaled,
    CropOutside    : Trect;
    CropHands      : array[INNER..BS] of Trect;
    CropCopy       : TBitmap;
    CropChanged,
    valid_crop,
    ShowCropped,
    ShowActualSize,
    CropToolOn     : boolean;
    CropMoveHandle : TCropHandle;
    sratio         : real;
  end;
  procedure Register;

{------------------------------------------------------------------------}
implementation

{------------------------------------------------------------------------}
procedure Register;
begin
  RegisterComponents('Samples',[TSimage]);
end;

{------------------------------------------------------------------------}
constructor TSimage.create(AOwner : Tcomponent);
begin
  inherited create(AOwner);
  OrigPict := TPicture.create;
  curfilename := '';
  CropToolOn := no;
  CropMoveHandle := noHandle;
  valid_crop := no;
end;

{------------------------------------------------------------------------}
destructor TSimage.Destroy;
begin
  OrigPict.free;
  inherited Destroy;
end;

{------------------------------------------------------------------------}
procedure TSimage.click;
begin
  if (CropMoveHandle = noHandle) then inherited click;
end;

{------------------------------------------------------------------------}
procedure TSimage.MouseMove(
                     Shift : TShiftState;
                      X, Y : Integer);
var
  cp      : TCropHandle;
  found   : boolean;
  xd,yd   : integer;
  NewRect : Trect;

{------------------------------------------------------------------------}
  function in_rect(var arect : Trect) : boolean;
  begin
    with arect do
      in_rect := (x > left) and (x < right) and (y > top) and (y < bottom);
  end;

{------------------------------------------------------------------------}
{------------------------------------------------------------------------}
begin
  inherited MouseMove(Shift,x,y);
  if not CropToolOn then exit;
  if (x < -10) or (y < -10) or (x > Width + 10) or (y > Height+ 10) then
    exit;
  found := no;
  if (CropMoveHandle <> noHandle) and (ssLeft in shift) then
  begin
    found := yes;
    if (x <> oldx) or (y <> oldy) then
    begin
      NewRect := CropRectScaled;
      with NewRect do
      begin
        xd := x - oldx;
        yd := y - oldy;
        case CropMoveHandle of
          INNER :
            begin
              inc(left,xd);
              inc(right,xd);
              inc(top,yd);
              inc(bottom,yd);
            end;
          UR :
            begin
              inc(right,xd);
              inc(top,yd);
            end;
          UL :
            begin
              inc(left,xd);
              inc(top,yd);
            end;
          BR :
            begin
              inc(right,xd);
              inc(bottom,yd);
            end;
          BL :
            begin
              inc(left,xd);
              inc(bottom,yd);
            end;
          LS : inc(left,xd);
          RS : inc(right,xd);
          TS : inc(top,yd);
          BS : inc(bottom,yd);
        end;
        if left >= right then
          if xd > 0 then
            right := left + 1
          else
            left := right - 1;
        if top >= bottom then
          if yd > 0 then
            bottom := top + 1
          else
            top := bottom - 1;
        if  (right >= 0) and (bottom >= 0)
          and (left <= width) and (top <= height) then
        begin
          EraseCrop;
          CropRectScaled := NewRect;
          draw_croptool(CropRectScaled);
          CropChanged := yes;
        end;
      end;
    end;
  end
  else
  begin
    if in_rect(CropOutside) then
    begin
      for cp := INNER to high(TCropHandle) do
        if in_rect(cropHands[cp]) then
        begin
          CropMoveHandle := cp;
          found := yes;
          case cp of
            inner : cursor := 2;
            UR,BL : cursor := crSizeNESW;
            UL,BR : cursor := crSizeNWSE;
            LS,RS : cursor := crSizeWE;
            TS,BS : cursor := crSizeNS;
          end;
          break;
        end;
    end;
  end;
  if not found then
  begin
    cursor := crDefault;
    CropMoveHandle := noHandle;
  end;
  oldx := x;
  oldy := y;
end;

{------------------------------------------------------------------------}
procedure TSimage.loaded;
begin
  inherited loaded;
  DesignedTop    := Top;
  DesignedLeft   := Left;
  DesignedWidth  := width;
  DesignedHeight := height;
  stretch := false;
  autosize := false;
  center := false;
end;

{------------------------------------------------------------------------}
function TSimage.validcrop(
                  var rect : Trect;
                  var pict : Tpicture
                         ) : boolean;
begin
  with rect,pict.bitmap do
  begin
    if left < 0 then left := width div 4;
    if top < 0 then top := height div 4;
    if right > width then right := (width div 4) * 3;
    if bottom > height then bottom := (height div 4) * 3;
    validcrop := ((left < right) and (top < bottom));
  end;
end;

{------------------------------------------------------------------------}
procedure TSimage.ChangeFromFile(
            const FileName : string;
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
var
  dumbool : boolean;
  rect : Trect;
  l : longint;
  SaveCursor : HCursor;
begin
  SaveCursor := screen.cursor;
  screen.cursor := crHourGlass;
  update;
  if CropToolOn then croptool_off(dumbool,rect);
  curfilename := filename;
  if filename = '' then
  begin
    HideNow;
    OrigPict.assign(nil);
    picture.assign(nil);
  end
  else
  begin
    OrigPict.LoadFromFile(FileName);
    CropRectActual := Crop;
    ShowCropped := Show_Cropped;
    ShowActualSize := Actual_Size;
    valid_crop := validcrop(CropRectActual,OrigPict);
    HideNow;
    picture.assign(Origpict);
    SizeAndShow;
  end;
  screen.cursor := SaveCursor;
end;

{------------------------------------------------------------------------}
procedure TSimage.ReplaceWith(
                 fromImage : TSimage;
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
var
  dumbool : boolean;
  rect : Trect;
  SaveCursor : HCursor;
begin
  SaveCursor := screen.cursor;
  screen.cursor := crHourGlass;
  if CropToolOn then croptool_off(dumbool,rect);
  curfilename := fromImage.get_filename;
  OrigPict.assign(fromImage.OrigPict);
  CropRectActual := Crop;
  ShowCropped := Show_Cropped;
  ShowActualSize := Actual_Size;
  valid_crop := validcrop(CropRectActual,Origpict);
  HideNow;
  picture.assign(Origpict);
  SizeAndShow;
  screen.cursor := SaveCursor;
end;

{------------------------------------------------------------------------}
procedure TSimage.ReDraw(
                      Crop : Trect;
              Show_Cropped : boolean;
               Actual_Size : boolean);
var
  SaveCursor : HCursor;
begin
  SaveCursor := screen.cursor;
  screen.cursor := crHourGlass;
  if curfilename <> '' then
  begin
    CropRectActual := Crop;
    ShowActualSize := Actual_Size;
    ShowCropped := Show_Cropped;
    valid_crop := validcrop(CropRectActual,Origpict);
    HideNow;
    picture.assign(Origpict);
    SizeAndShow;
  end;
  screen.cursor := SaveCursor;
end;

{------------------------------------------------------------------------}
function TSimage.get_filename : string;
begin
  result := curfilename;
end;

{------------------------------------------------------------------------}
function TSimage.get_rect : Trect;
begin
  result := CropRectActual;
end;

{------------------------------------------------------------------------}
procedure TSimage.SetDesignedSize(
                         t : integer;
                         l : integer;
                         w : integer;
                         h : integer);
begin
  DesignedTop    := t;
  DesignedLeft   := l;
  DesignedWidth  := w;
  DesignedHeight := h;
end;

{------------------------------------------------------------------------}
procedure TSimage.GetDesignedSize(
                     Var t : integer;
                     Var l : integer;
                     Var w : integer;
                     Var h : integer);
begin
  t := DesignedTop;
  l := DesignedLeft;
  w := DesignedWidth;
  h := DesignedHeight;
end;

{------------------------------------------------------------------------}
procedure TSimage.HideNow;
begin
  hide;
  update;                                 {causes hide to actually happen}
end;

{------------------------------------------------------------------------}
procedure TSimage.SizeAndShow;
var
  wratio,
  hratio     : real;
  recttop,
  rectleft,
  rectwidth,
  rectheight,
  wOffset,
  hOffset    : integer;
  new_width,
  new_height : word;
  rect : Trect;
begin
  if valid_crop and ShowCropped then
  begin
    with CropRectActual do
    begin
      recttop    := top;
      rectleft   := left;
      rectwidth  := right - left + 1;
      rectheight := bottom - top + 1;
    end
  end
  else
  begin
    with Picture do
    begin
      recttop    := 0;
      rectleft   := 0;
      rectwidth  := width;
      rectheight := height;
    end;
  end;
  if (rectwidth <> 0) and (rectheight <> 0) then
  begin
    if ShowActualSize then
    begin
      sratio := 1.0;
      new_width := rectwidth;
      new_height := rectheight;
    end
    else
    begin
{scale picture proportionary to fit into full designed size best}
      wratio := DesignedWidth / rectwidth;
      hratio := DesignedHeight / rectheight;
      if wratio > hratio then
        sratio := hratio
      else
        sratio := wratio;
      new_width := trunc(rectwidth * sratio);
      new_height := trunc(rectheight * sratio);
      if new_width > DesignedWidth then new_width := DesignedWidth;
      if new_height > DesignedHeight then new_Height := DesignedHeight;
    end;
    wOffset := (DesignedWidth - new_width) div 2;
    if wOffset < 0 then wOffset := 0;
    hOffset := (DesignedHeight - new_height) div 2;
    if hOffset < 0 then hOffset := 0;
    SetStretchBltMode(picture.bitmap.canvas.handle,STRETCH_DELETESCANS);
    if sratio < 1 then
    begin
      With picture.bitmap.canvas do
        StretchBlt(handle,0,0,new_width,new_height
                        ,handle,rectleft,recttop,rectwidth,rectheight,srccopy);
    end
    else
      if sratio > 1 then
      begin
        picture.bitmap.height := new_height;
        picture.bitmap.width := new_width;
        With picture.bitmap.canvas  do
          StretchBlt(handle,0,0,new_width,new_height
                    ,OrigPict.Bitmap.canvas.handle
                    ,rectleft,recttop,rectwidth,rectheight,srccopy);
      end
      else                                                         {sratio = 1}
      begin
        if valid_crop and ShowCropped and ShowActualSize then
          With picture.bitmap.canvas do
            StretchBlt(handle,0,0,new_width,new_height
                        ,handle,rectleft,recttop,rectwidth,rectheight,srccopy);
      end;
    SetBounds(DesignedLeft + wOffset,DesignedTop + hOffset
                                                        ,new_width,new_height);
  end;
  show;
end;

{------------------------------------------------------------------------}
procedure TSimage.erasecrop;
begin
  picture.bitmap.canvas.CopyRect(CropOutside,CropCopy.canvas,CropOutside);
end;

{------------------------------------------------------------------------}
procedure TSimage.croptool_off(
               var changed : boolean;
                  var Crop : Trect);
begin
  if CropToolOn then
  begin
    erasecrop;
    CropCopy.free;
    CropToolOn := no;
{scale crop back to original picture units}
    CropRectActual := CropRectScaled;
    with CropRectActual do
    begin
      left   := trunc(left   / sratio);
      right  := trunc(right  / sratio);
      top    := trunc(top    / sratio);
      bottom := trunc(bottom / sratio);
    end;
    changed := CropChanged;
    Crop := CropRectActual;
    valid_crop := validcrop(CropRectActual,Origpict);
  end;
end;

{------------------------------------------------------------------------}
procedure TSimage.draw_croptool(
                      Crop : Trect);

{------------------------------------------------------------------------}
  procedure corner(  which : TCropHandle;
                       x,y : integer);
  begin
    with canvas do
    begin
      brush.color := clwhite;
      case which of
        UR :
          begin
            fillrect(rect(x+1,y-5,x+6,y));
            cropHands[which] := rect(x,y-6,x+7,y+1);
          end;
        UL :
          begin
            fillrect(rect(x-5,y-5,x,y));
            cropHands[which] := rect(x-6,y-6,x+1,y+1);
          end;
        BR :
          begin
            fillrect(rect(x+1,y+1,x+6,y+6));
            cropHands[which] := rect(x,y,x+7,y+7);
          end;
        BL :
          begin
            fillrect(rect(x-5,y+1,x,y+6));
            cropHands[which] := rect(x-6,y,x+1,y+7);
          end;
        RS :
          begin
            fillrect(rect(x+2,y-2,x+6,y+3));
            cropHands[which] := rect(x+1,y-3,x+7,y+4);
          end;
        LS :
          begin
            fillrect(rect(x-5,y-2,x-1,y+3));
            cropHands[which] := rect(x-6,y-3,x,y+4);
          end;
        TS :
          begin
            fillrect(rect(x-2,y-5,x+3,y-1));
            cropHands[which] := rect(x-3,y-6,x+4,y);
          end;
        BS :
          begin
            fillrect(rect(x-2,y+2,x+3,y+6));
            cropHands[which] := rect(x-3,y+1,x+4,y+7);
          end;
      end;
      brush.color := clblack;
      framerect(cropHands[which]);
    end;
  end;

{------------------------------------------------------------------------}
{------------------------------------------------------------------------}
begin
  with CropRectScaled do                        {rect is actual pixels desired}
  begin
{save the hot area coors}
    cropOutside := rect(left-6,top-6,right+7,bottom+7);
    CropHands[INNER] := rect(left-2,top-2,right+3,bottom+3);
    canvas.brush.color := clwhite;   {white boarder around pixels}
    canvas.framerect(rect(left-1,top-1,right+2,bottom+2));
    canvas.brush.color := clblack;      {black frame around white}
    canvas.framerect(CropHands[INNER]);
    corner(UR,right,top);
    corner(UL,left,top);
    corner(BR,right,bottom);
    corner(BL,left,bottom);
    corner(RS,right,(bottom + top) div 2);
    corner(LS,left,(bottom + top) div 2);
    corner(TS,(right + left) div 2,top);
    corner(BS,(right + left) div 2,bottom);
  end;
end;

{------------------------------------------------------------------------}
procedure TSimage.croptool_on;
begin;
  if CropToolOn then exit;
  CropToolOn := yes;
  CropChanged := no;
  CropCopy := TBitmap.create;
  CropCopy.assign(picture.bitmap);
  if not valid_crop then
    with CropRectActual, origpict do
    begin
      left := width div 4;
      right := 3 * left;
      top := height div 4;
      bottom := 3 * top;
    end;
  with CropRectActual do
  begin
    CropRectScaled.left   := trunc(left   * sratio);
    CropRectScaled.right  := trunc(right  * sratio);
    CropRectScaled.top    := trunc(top    * sratio);
    CropRectScaled.bottom := trunc(bottom * sratio);
  end;
  draw_croptool(CropRectScaled);
end;

{no Initialization Block}
{------------------------------------------------------------------------}
end.