xsimageeffect.pas

delphi图形程序开发,就是怎么样给图片加文字

unit XsImageEffect;

interface

uses
  Windows, Messages, SysUtils, Classes, Controls, ExtCtrls, Graphics, Math,
  Forms, Dialogs;

type
  TXsImageEffect = class(TImage)
  private
    FDegree: Integer;
    FSelectArea: Boolean;
    FPForm: TForm;
    AntsTimer: TTimer;
    X1, Y1, X2, Y2: Integer; //Ants used
    DX, DY: Integer;
    FDragInForm: Boolean; //Drag In Form used
    DMD: Boolean;
    FModifyPicture: Boolean;
    FBaseColor: Integer;
    FColorArea: Integer;
    MOrgBitmap: TBitmap;
    procedure LeftRightMirror(Bitmap: TBitmap);
    procedure TopBottomMirror(Bitmap: TBitmap);
    function ChangeToBitmap(Graphic: TGraphic): TBitmap;
    function CreateRotatedBitmap(Bitmap: TBitmap; Angle: Extended;
      bgColor: TColor): TBitmap;
    procedure SetDegree(Value: Integer);
    procedure RemoveTheRect; //Ants function
    procedure DrawTheRect;   //Ants function
    procedure AntsMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); //Ants Mouse Event
    procedure AntsMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer); //Ants Mouse Event
    procedure AntsMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); //Ants Mouse Event
    procedure SetSelectArea(Value: Boolean);
    procedure AntsTimerEvent(Sender: TObject);
    procedure DragFormMouseDown(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); //DragInForm Mouse Event
    procedure DragFormMouseMove(Sender: TObject; Shift: TShiftState; X,
       Y: Integer); //DragInForm Mouse Event
    procedure DragFormMouseUp(Sender: TObject; Button: TMouseButton;
       Shift: TShiftState; X, Y: Integer); //DragInForm Mouse Event
    procedure SetDragInForm(Value: Boolean);
    function AnalysisColorArea(R, G, B, BaseColor, ColorArea: Integer): Boolean;
    procedure SetModifyPicture(Value: Boolean);
  protected
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X: Integer; Y: Integer); override;
    procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer);
      override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer;
      Y: Integer); override;
    property ModifyPicture: Boolean read FModifyPicture write SetModifyPicture default True;
  public
    procedure SetLeftRightMirror();
    procedure SetTopBottomMirror();
    procedure CutOutSelect();
    procedure SelectAll();
    procedure GetPictureContent();
    procedure AutoSelectContent();
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property SetRotateDegree: Integer read FDegree write SetDegree default 0;
    property SelectArea: Boolean read FSelectArea write SetSelectArea default False;
    property DragInForm: Boolean read FDragInForm write SetDragInForm default False;
    property BaseColor: Integer read FBaseColor write FBaseColor default 80;
    property ColorArea: Integer read FColorArea write FColorArea default 20;
    property Color;
  end;

procedure Register;

implementation

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

procedure Register;
begin
  RegisterComponents('XSpace', [TXsImageEffect]);
end;

procedure RestrictCursorToDrawingArea(const Image: TImage);
var
   CursorClipArea: TRect;
begin
   CursorClipArea := Bounds(Image.ClientOrigin.X, Image.ClientOrigin.Y,
      Image.Width, Image.Height);
   Windows.ClipCursor(@CursorClipArea)
end {RestrictCursorToDrawingArea};


procedure RemoveCursorRestrictions;
begin
   Windows.ClipCursor(nil)
end {RemoveCursorRestrictions};


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

{ TXsImageEffect }

function TXsImageEffect.AnalysisColorArea(R, G, B, BaseColor,
  ColorArea: Integer): Boolean;
begin
  Result:= True;
  if (R<=BaseColor) and (G<=BaseColor) and (B<=BaseColor) then
  begin
    Result:= False;
    if (R>=(BaseColor-ColorArea)) and (R<=BaseColor) and
      (G>=(BaseColor-ColorArea)) and (G<=BaseColor) and
      (B>=(BaseColor-ColorArea)) and (B<=BaseColor) then
      Result:= False;
  end;
end;

procedure TXsImageEffect.AntsMouseDown(Sender: TObject;
  Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
begin
   X := X + (Sender as TImage).Left;
   Y := Y + (Sender as TImage).Top;

   RemoveTheRect; // Erase any existing rectangle
   X1 := X;
   Y1 := Y;

   X2 := X;
   Y2 := Y;

   // Force mouse movement to stay within TImage
   RestrictCursorToDrawingArea((Sender as TImage));
   if not AntsTimer.Enabled then
   begin
     AntsTimer.OnTimer:= AntsTimerEvent;
     AntsTimer.Enabled:= True;
   end;
end;

procedure TXsImageEffect.AntsMouseMove(Sender: TObject; Shift: TShiftState;
  X, Y: Integer);
begin
   if ssLeft in Shift
      then begin
         X := X + (Sender as TImage).Left;
         Y := Y + (Sender as TImage).top;

         RemoveTheRect; // Erase any existing rectangle
         X2 := X; Y2 := Y; // Save the new corner where the mouse is
         DrawTheRect; // Draw the Rect now... don't wait for the timer!
      end;
end;

procedure TXsImageEffect.AntsMouseUp(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
   RemoveCursorRestrictions
end;

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

procedure TXsImageEffect.AutoSelectContent;
var
  ob: TBitmap;
  Bitmap1: TBitmap;
  x, y, hx, hy, ex, ey: Integer;
  P: PByteArray;
  R, G, B: Integer;
begin
  ob:= ChangeToBitmap(Picture.Graphic);
  Bitmap1:= TBitmap.Create;
  Bitmap1.Assign(ob);
  Bitmap1.PixelFormat:= pf24bit;
  ob.Free;
  hx:= Picture.Width-1;
  hy:= Picture.Height-1;
  ex:= 0;
  ey:= 0;
  for y:=0 to Bitmap1.Height-1 do
  begin
    P:= Bitmap1.ScanLine[y];
    for x:=0 to Bitmap1.Width-1 do
    begin
      R:= P[x * 3];
      G:= P[x * 3 + 1];
      B:= P[x * 3 + 2];
      if RGB(R, G, B) <> ColorToRGB(Color) then
      begin
        if x < hx then
          hx:= x;
        if y < hy then
          hy:= y;
        if x > ex then
          ex:= x;
        if y > ey then
          ey:= y;
      end;
    end;
  end;
  SetSelectArea(True);
  X1:= Left + hx;
  X2:= Left + ex;
  Y1:= Top + hy;
  Y2:= Top + ey;
  DrawTheRect;
end;

function TXsImageEffect.ChangeToBitmap(Graphic: TGraphic): TBitmap;
begin
  if not Picture.Graphic.Empty then
  begin
    if not (Picture.Graphic is TBitmap) then
    begin
      Result := TBitmap.Create;
      Result.Canvas.Brush.Color := Color;
      Result.Width := Picture.Width;
      Result.Height := Picture.Height;
      Result.Canvas.Draw(0, 0, Picture.Graphic);
      Result.Assign(Result);
    end else
    begin
      Result:= TBitmap.Create;
      Result.Assign(Picture.Bitmap);
    end;
  end;
end;


constructor TXsImageEffect.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FPForm:= (AOwner as TForm);
  AntsTimer:= TTimer.Create(Self);
  MOrgBitmap:= TBitmap.Create;
  FModifyPicture:= True;
  FBaseColor:= 80;
  FColorArea:= 20;
  Color:= clWhite;
end;

function TXsImageEffect.CreateRotatedBitmap(Bitmap: TBitmap;
  Angle: Extended; bgColor: TColor): TBitmap;
type
  IntegerArray  = array[0..$EFFFFFF] of Integer;
  PIntegerArray = ^IntegerArray;
var
  CosTheta, SinTheta: Extended;
  iCosTheta, iSinTheta: Integer;
  xSrc, ySrc: Integer;
  xDst, yDst: Integer;
  xODst, yODst: Integer;
  xOSrc, yOSrc: Integer;
  xPrime, yPrime: Integer;
  srcWidth, srcHeight: Integer;
  dstWidth, dstHeight: Integer;
  yPrimeSinTheta, yPrimeCosTheta: Integer;
  srcBits: PIntegerArray;
  dstBits: PInteger;
begin
  // Workaround SinCos bug (-180 <= Angle <= +180)
  while Angle > +180.0 do Angle := Angle - 360.0;
  while Angle < -180.0 do Angle := Angle + 360.0;
  // end of workaround SinCos bug
  SinCos(Pi * -Angle / 180.0, SinTheta, CosTheta);
  iSinTheta := Trunc(SinTheta * (1 shl 16));
  iCosTheta := Trunc(CosTheta * (1 shl 16));
  Bitmap.PixelFormat := pf32bit;
  srcWidth := Bitmap.Width;
  srcHeight := Bitmap.Height;
  srcBits := Bitmap.ScanLine[srcHeight-1];
  xOSrc := srcWidth shr 1;
  yOSrc := srcHeight shr 1;
  dstWidth := SmallInt((srcWidth * Abs(iCosTheta) + srcHeight * Abs(iSinTheta)) shr 16);
  dstHeight := SmallInt((srcWidth * Abs(iSinTheta) + srcHeight * Abs(iCosTheta)) shr 16);
  xODst := dstWidth shr 1;
  if ((Angle = 0.0) or (Angle = -90.0)) and not Odd(dstWidth) then
    Dec(xODst);
  yODst := dstHeight shr 1;
  if ((Angle = 0.0) or (Angle = +90.0)) and not Odd(dstHeight) then
    Dec(yODst);
  Result := TBitmap.Create;
  Result.Canvas.Brush.Color := bgColor;
  Result.Width := dstWidth;
  Result.Height := dstHeight;
  Result.PixelFormat := pf32bit;
  dstBits := @(PIntegerArray(Result.ScanLine[0])[dstWidth-1]);
  yPrime := yODst;
  for yDst := dstHeight - 1 downto 0 do
  begin
    yPrimeSinTheta := yPrime * iSinTheta;
    yPrimeCosTheta := yPrime * iCosTheta;
    xPrime := xODst;
    for xDst := dstWidth - 1 downto 0 do
    begin
      xSrc := SmallInt((xPrime * iCosTheta - yPrimeSinTheta) shr 16) + xOSrc;
      ySrc := SmallInt((xPrime * iSinTheta + yPrimeCosTheta) shr 16) + yOSrc;
      if (DWORD(ySrc) < DWORD(srcHeight)) and (DWORD(xSrc) < DWORD(srcWidth)) then
      begin
        dstBits^ := srcBits[ySrc * srcWidth + xSrc];
      end;
      Dec(dstBits);
      Dec(xPrime);
    end;
    Dec(yPrime);
  end;
  Result.HandleType := bmDDB;
end;

procedure TXsImageEffect.CutOutSelect();
var
  Bitmap1, Bitmap2, ob: TBitmap;
  SelRect, RatioRect: TRect;
  hr, zr: Real;
begin
  if (X2 <> 0) and (Y2 <> 0) and FSelectArea then
  begin
    Bitmap1:= TBitmap.Create;
    Bitmap2:= TBitmap.Create;
    Bitmap1.PixelFormat:= pf24bit;
    ob:= ChangeToBitmap(Picture.Graphic);
    Bitmap2.Assign(ob);
    ob.Free;
    Bitmap2.PixelFormat:= pf24bit;
    SelRect:= Rect(X1-Self.Left,Y1-Self.Top,X2-Self.Left,Y2-Self.Top);
    Bitmap1.Width:= SelRect.Right - SelRect.Left;
    Bitmap1.Height:= SelRect.Bottom - SelRect.Top;
    if Stretch then
    begin
      hr:= Bitmap2.Width / Width;
      zr:= Bitmap2.Height / Height;
      RatioRect:= Rect(Round(SelRect.Left*hr),Round(SelRect.Top*zr),
        Round(SelRect.Right*hr),
        Round(SelRect.Bottom*zr));
      Bitmap1.Width:= RatioRect.Right - RatioRect.Left;
      Bitmap1.Height:= RatioRect.Bottom - RatioRect.Top;
      Bitmap1.Canvas.CopyRect(Rect(0,0,RatioRect.Right-RatioRect.Left,
        RatioRect.Bottom-RatioRect.Top),Bitmap2.Canvas,RatioRect);
    end else
      Bitmap1.Canvas.CopyRect(Rect(0,0,SelRect.Right-SelRect.Left,
        SelRect.Bottom-SelRect.Top),Bitmap2.Canvas,SelRect);
    AntsTimer.Enabled:= False;
    AntsTimer.OnTimer:= nil;
    RemoveTheRect;
    Width:= Bitmap1.Width;
    Height:= Bitmap1.Height;