fastimage.pas

一个基于不需引擎的文件管理系统,使用了许多界面比较好的控件

unit FastImage;

//release 0.6;

//  Contributors:
//
//  Gordon Alex Cowie III (aka "GoRDy") <[e-mail]>
//  www.jps.net/gfody (currently down (jps sucks fat cock))
//  TFastBMP unit.
//
//  Andreas Goransson <[e-mail]>
//   -Texture filter
//   -Added some optimizations here an there
//
//  Earl F. Glynn <[e-mail]>
//   -Rotation optimizations
//   -Computer lab: www.infomaster.net/external/efg/
//
//  Vit Kovalcik <[e-mail]>
//   -Optimized Resize method
//   -Check out UniDib for 4,8,16,24,32 bit dibs!
//   -www.geocities.com/SiliconValley/Hills/1335/
//
//  Anders Melander <[e-mail]>
//  David Ullrich <[e-mail]>
//  Dale Schumacher
//   -Bitmap Resampler

//  "William W. Miller, Jr." <[e-mail]>
//  http://www.software.adirondack.ny.us
//  - rubberbanding and selections.
//  - Smooth rotating and scaling.

interface

uses
  Windows, Classes, Controls, forms, dialogs,
  ExtCtrls,filectrl,stdctrls,sysutils,fastBMP,graphics,clipbrd;

type
   PBytes = ^TBytes;
   TBytes = array [0..MaxInt-1] of Byte;
   type pBigBytes=^TBytes;


   TThreeBytes = array [0..2] of Byte;

type
  TFastImage = class(TScrollBox)
  private
         FBMP : TFastBMP;
         FPaintBox:TPaintBox;
         FFilename : string;
         FAutosize : Boolean;
         FStretch  : Boolean;
         FTiling   : Boolean;
         FFillColor: TFColor;
         FLineColor: TFColor;
         FSelection: Boolean;
         RLine,BLine,GLine,RFill,BFill,GFill:byte;  
         XOrigin,YOrigin,XFinal,YFinal : Integer;
         Timer1:TTimer;
         FCLWHITE,FCLRED:TFColor;
         procedure SetFileName(name:string);
         procedure SetWidth(value:integer);
         procedure SetHeight(value:integer);
         Function  GetWidth:integer;       
         Function  GetHeight:integer;
         procedure SetFillColor(color:TFColor);
         procedure SetLineColor(color:TFColor);
         function  GetFillColor:TFColor;
         function  GetLineColor:TFColor;
         procedure RemoveTheRect;
         procedure DrawTheRect;
  public
        constructor Create(AOwner:TComponent);override;
        destructor Destroy;override;
  protected
        procedure paint(sender:TObject);
        procedure CheckSize(sender:TObject);
        procedure MouseDownOnPicture(Sender: TObject;
              Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
        procedure MouseMoveOnPicture(Sender: TObject; Shift: TShiftState; X, Y: Integer);
        procedure MouseUpOnPicture(Sender: TObject;
              Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
  published
        property Filename : string read FFilename write SetFilename;
        property Autosize : boolean read FAutosize write FAutosize;
        property Stretch  : boolean read FStretch write FStretch;
        property Selection  : boolean read FSelection write FSelection;
        property FastBMP  : TFastBMP read FBMP write FBMP;
        property Tiling  : Boolean read FTiling write FTiling;
        property PictureWidth: integer read GetWidth write SetWidth;
        property PictureHeight: integer read GetHeight write SetHeight;
        property FillColor:TFColor read GetFillColor write SetFillColor;
        property LineColor:TFColor read GetLineColor write SetLineColor;
        procedure Flip;
        procedure Mirror;
        procedure Rotate(degree:extended;Smooth:Boolean);
        procedure AddNoiseFilter(value:byte);
        procedure SandyFilter(value:byte);
        procedure SprayFilter(value:byte);
        procedure BlurFilter(value:byte);
        procedure WaveFilter(XDIV,YDIV,RatioVal:byte);
        procedure WaveWrapFilter(XDIV,YDIV,RatioVal:byte);
        procedure SmoothPoint(xk,yk:integer);
        procedure AntiAliasRect(XOrigin,YOrigin,XFinal,YFinal : Integer);
        procedure AntiAlias;
        procedure Sharpen;
        procedure DiscardColor;
        procedure SplitBlur(Amount:Integer);
        procedure GaussianBlur(Amount:Integer);
        procedure Resample(w,h:integer;Filter:TFilterProc;FWidth:Single);
        procedure Update;
        Procedure HorGradientLine(XOrigin,XFinal,y:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);
        Procedure Column(XOrigin,XFinal,YOrigin,YFinal:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);
        procedure Sphere(xcenter,a,ycenter,b:integer;r1,g1,b1,r2,g2,b2:byte;smooth:boolean);
        procedure GrayScale;
        procedure TurnCW;
        procedure TurnCCW;
        procedure HScroll(Amount:Integer);
        procedure VScroll(Amount:Integer);
        procedure HorLine(XOrigin,XFinal,y:Integer);
        procedure VertLine(x,YOrigin,YFinal:integer);
        procedure Rectangle(XOrigin,YOrigin,XFinal,YFinal:integer);
        procedure OpenPCD(filename:string;PCDsize:integer);
        procedure Timer(Sender: TObject);
        procedure RotatePicture(from_FastBMP, to_FastBMP : TFastBmp;theta : Single;
                  from_x1, from_y1, from_x2, from_y2 : Integer;
                  to_x1, to_y1, to_x2, to_y2 : Integer);
        procedure GetRotatedSize(theta : Single;old_width, old_height : Integer;
                  var new_width, new_height : Integer);
        procedure SmoothRotate(Angle:extended);
        procedure SmoothScale(scale:single);
        procedure ShrinkPicture(
                  from_FastBMP, to_FastBMP : TFastBMP;
                  from_x1, from_y1, from_x2, from_y2 : Integer;
                  to_x1, to_y1, to_x2, to_y2 : Integer);
        procedure EnlargePicture(
                  from_FastBMP, to_FastBMP : TFastBMP;
                  from_x1, from_y1, from_x2, from_y2 : Integer;
                  to_x1, to_y1, to_x2, to_y2 : Integer);
        procedure InterpolateRect(x1,y1,x2,y2:Integer;c00,c10,c01,c11:TFColor);
        procedure SelectAll;
        procedure Copy;
        procedure Contrast(Amount:Integer);
        procedure Saturation(Amount:Integer);
        procedure Lightness(Amount:Integer);

end;

implementation

var  
         Counter : Byte;
         CounterStart : Byte;
         Looper : LongInt;

constructor TFastImage.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  Fautosize:=true;
  width:=260;
  height:=260;
  FFillColor.r:=255;
  FFillColor.g:=255;
  FFillColor.b:=255;
  RLine:=0;GLine:=0;BLine:=0;
  RFill:=255;GFill:=255;BFill:=255;
  FLineColor.r:=0;
  FLineColor.g:=0;
  FLineColor.b:=0;
  FBMP:=TFastBMP.Create(256,256);
  FPaintBox:=TPaintBox.Create(self);
  FPaintBox.Width:=256;
  FPaintBox.Height:=256;
  FPaintBox.Top:=0;
  FPaintBox.Left:=0;
  FPaintBox.OnPaint:=paint;
  insertcontrol(FPaintBox);
  OnResize:=CheckSize;

  XOrigin := 0; YOrigin := 0;
  XFinal := 0; YFinal := 0;
  FPaintBox.Canvas.Pen.Color := Color;
  FPaintBox.Canvas.Brush.Color := Color;
  FPaintBox.OnMouseDown:=mousedownOnPicture;
  FPaintBox.OnMouseUp:=mouseUpOnPicture;
  FPaintBox.OnMouseMove:=mouseMoveOnPicture;
  CounterStart := 128;
  Timer1:=TTimer.Create(self);
  Timer1.Interval := 100;
  Timer1.Enabled := True;
  Looper := 0;
  Timer1.OnTimer:=Timer;
  FCLWHITE:=FRGB(255,255,255);
  FCLRED:=FRGB(255,0,0);
end;

destructor TFastImage.Destroy;
begin
  if Timer1<>nil then
    timer1.free;
  if FBMP<>nil then
    FBMP.free;
  if FPaintBox<>nil then
    FPaintBox.free;
  inherited Destroy;
end;


{==============================================================================}
function NormalizeRect(R: TRect): TRect;
{==============================================================================}
begin
  // This routine normalizes a rectangle. It makes sure that the Left,Top
  // coords are always above and to the left of the Bottom,Right coords.
  with R do
    if Left > Right then
      if Top > Bottom then
        Result := Rect(Right,Bottom,Left,Top)
      else
        Result := Rect(Right,Top,Left,Bottom)
    else
      if Top > Bottom then
        Result := Rect(Left,Bottom,Right,Top)
      else
        Result := Rect(Left,Top,Right,Bottom);
end;



{==============================================================================}
procedure TFastImage.RemoveTheRect;
{==============================================================================}
var
  R : TRect;
begin
  R := NormalizeRect(Rect(XOrigin,YOrigin,XFinal,YFinal));  // Rectangle might be flipped
  InflateRect(R,1,1);                     // Make the rectangle 1 pixel larger
  InvalidateRect(Handle,@R,True);         // Mark the area as invalid
  InflateRect(R,-2,-2);                   // Now shrink the rectangle 2 pixels
  ValidateRect(Handle,@R);                // And validate this new rectangle.
  // This leaves a 2 pixel band all the way around 
  // the rectangle that will be erased & redrawn
  UpdateWindow(Handle);
end;

{==============================================================================}
procedure MovingDots(X,Y: Integer; TheCanvas: TCanvas); stdcall;
{==============================================================================}
begin
  Inc(Looper);
  Counter := Counter shl 1;              // Shift the bit left one
  if Counter = 0 then Counter := 1;      // If it shifts off left, reset it
  if (Counter and 224) > 0 then          // Are any of the left 3 bits set?
    TheCanvas.Pixels[X,Y] := clWhite     // Erase the pixel
  else
    TheCanvas.Pixels[X,Y] := clBlack;    // Draw the pixel 
end;


{==============================================================================}
procedure TFastImage.DrawTheRect;
{==============================================================================}
var Y,X:integer;
begin
  // Determines starting pixel color of Rect
  Counter := CounterStart;
  // Use LineDDA to draw each of the 4 edges of the rectangle  
  Update;
  LineDDA(XOrigin,YOrigin,XFinal,YOrigin,@MovingDots,LongInt(FPaintBox.Canvas));
  LineDDA(XFinal,YOrigin,XFinal,YFinal,@MovingDots,LongInt(FPaintBox.Canvas));
  LineDDA(XFinal,YFinal,XOrigin,YFinal,@MovingDots,LongInt(FPaintBox.Canvas));
  LineDDA(XOrigin,YFinal,XOrigin,YOrigin,@MovingDots,LongInt(FPaintBox.Canvas));
end;

{==============================================================================}
procedure TFastImage.Timer(Sender: TObject);
{==============================================================================}
begin
 CounterStart := CounterStart shr 2;           // Shl 1 will move rect slower
  if CounterStart = 0 then CounterStart := 128; // If bit is lost, reset it
  if selection then DrawTheRect;                                  // Draw the rectangle
end;


{==============================================================================}
procedure TFastImage.MouseDownOnPicture(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
{==============================================================================}
begin
 if FSelection then
    begin
    RemoveTheRect;                               // Erase any existing rectangle
    XOrigin := X; YOrigin := Y; XFinal := X; YFinal := Y;
    end;
end;

{==============================================================================}
procedure TFastImage.MouseUpOnPicture(Sender: TObject;Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
{==============================================================================}
begin

end;

{==============================================================================}
procedure TFastImage.MouseMoveOnPicture(Sender: TObject;Shift: TShiftState; X,
  Y: Integer);
{==============================================================================}
begin
if (ssLeft in Shift) and selection then
    begin
      RemoveTheRect;         // Erase any existing rectangle
      XFinal := X; YFinal := Y;      // Save the new corner where the mouse is
      DrawTheRect;           // Draw the Rect now... don't wait for the timer!
    end;
end;

procedure TFastImage.SelectAll;
begin
  XOrigin :=0;
  YOrigin :=0;
  XFinal := FBMP.Width-1;
  YFinal := FBMP.Height-1;
end;

procedure TFastImage.Copy;
var
  FBMPCopy:TFastBMP;
  Line1,Line2:PLine;
  i,j:integer;
  bitmap:TBitmap;
  MyFormat : Word;