_graphics.pas

East make Tray Icon in delphi

{**************************************************************************************************}
{                                                                                                  }
{ Project JEDI Code Library (JCL)                                                                  }
{                                                                                                  }
{ The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); }
{ you may not use this file except in compliance with the License. You may obtain a copy of the    }
{ License at http://www.mozilla.org/MPL/                                                           }
{                                                                                                  }
{ Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF   }
{ ANY KIND, either express or implied. See the License for the specific language governing rights  }
{ and limitations under the License.                                                               }
{                                                                                                  }
{ The Original Code is JclGraphics.pas.                                                            }
{                                                                                                  }
{ The resampling algorithms and methods used in this library were adapted by Anders Melander from  }
{ the article "General Filtered Image Rescaling" by Dale Schumacher which appeared in the book     }
{ Graphics Gems III, published by Academic Press, Inc. Additional improvements were done by David  }
{ Ullrich and Josha Beukema.                                                                       }
{                                                                                                  }
{ (C)opyright 1997-1999 Anders Melander                                                            }
{                                                                                                  }
{ The Initial Developers of the Original Code are Alex Denissov, Wim De Cleen, Anders Melander     }
{ and Mike Lischke. Portions created by these individuals are Copyright (C) of these individuals.  }
{ All Rights Reserved.                                                                             }
{                                                                                                  }
{ Contributors:                                                                                    }
{   Alexander Radchenko                                                                            }
{   Charlie Calvert                                                                                }
{   Marcel van Brakel                                                                              }
{   Marcin Wieczorek                                                                               }
{   Matthias Thoma (mthoma)                                                                        }
{   Petr Vones (pvones)                                                                            }
{   Robert Marquardt (marquardt)                                                                   }
{   Robert Rossmair (rrossmair)                                                                    }
{                                                                                                  }
{**************************************************************************************************}

{$IFDEF PROTOTYPE}
// Last modified: $Date: 2005/03/08 08:33:19 $
{$ELSE ~PROTOTYPE}
// For history, see end of file

{$IFDEF VCL}
unit JclGraphics;
{$ELSE VisualCLX}
unit JclQGraphics;
{$ENDIF VisualCLX}
{$ENDIF ~PROTOTYPE}

{$I jcl.inc}

interface

uses
  {$IFDEF MSWINDOWS}
  Windows,
  {$ENDIF MSWINDOWS}
  Classes, SysUtils,
  {$IFDEF VisualCLX}
  Types, QGraphics, JclQGraphUtils,
  {$ELSE}
  Graphics, JclGraphUtils,
  {$ENDIF VisualCLX}
  JclBase;

type
  EJclGraphicsError = class(EJclError);

  TDynDynIntegerArrayArray = array of TDynIntegerArray;
  TDynPointArray = array of TPoint;
  TDynDynPointArrayArray = array of TDynPointArray;
  TPointF = record
    X: Single;
    Y: Single;
  end;
  TDynPointArrayF = array of TPointF;

  { TJclBitmap32 draw mode }
  TDrawMode = (dmOpaque, dmBlend);

  { stretch filter }
  TStretchFilter = (sfNearest, sfLinear, sfSpline);

  TConversionKind = (ckRed, ckGreen, ckBlue, ckAlpha, ckUniformRGB, ckWeightedRGB);

  { resampling support types }
  TResamplingFilter =
    (rfBox, rfTriangle, rfHermite, rfBell, rfSpline, rfLanczos3, rfMitchell);

  { Matrix declaration for transformation }
  //  modify Jan 28, 2001 for use under BCB5
  //         the compiler show error 245 "language feature ist not available"
  //         we must take a record and under this we can use the static array
  //  Note:  the sourcecode modify general from M[] to M.A[] !!!!!
  //  TMatrix3d = array [0..2, 0..2] of Extended;  // 3x3 double precision

  TMatrix3d = record
    A: array [0..2, 0..2] of Extended;
  end;

  TDynDynPointArrayArrayF = array of TDynPointArrayF;

  TScanLine = array of Integer;
  TScanLines = array of TScanLine;

  TLUT8 = array [Byte] of Byte;
  TGamma = array [Byte] of Byte;
  TColorChannel = (ccRed, ccGreen, ccBlue, ccAlpha);

  TGradientDirection = (gdVertical, gdHorizontal);

  TPolyFillMode = (fmAlternate, fmWinding);
  TJclRegionCombineOperator = (coAnd, coDiff, coOr, coXor);
  TJclRegionBitmapMode = (rmInclude, rmExclude);
  TJclRegionKind = (rkNull, rkSimple, rkComplex, rkError);

//  modify Jan 28, 2001 for use under BCB5
//         the compiler show error 245 "language feature ist not available"
//         wie must take a record and under this we can use the static array
//  Note:  for init the array we used initialisation at the end of this unit
//
//  const
//    IdentityMatrix: TMatrix3d = (
//      (1, 0, 0),
//      (0, 1, 0),
//      (0, 0, 1));

var
  IdentityMatrix: TMatrix3d;

// Classes
type
  {$IFDEF VCL}
  TJclDesktopCanvas = class(TCanvas)
  private
    FDesktop: HDC;
  public
    constructor Create;
    destructor Destroy; override;
  end;

  TJclRegion = class;

  TJclRegionInfo = class(TObject)
  private
    FData: Pointer;
    FDataSize: Integer;
    function GetBox: TRect;
  protected
    function GetCount: Integer;
    function GetRect(index: Integer): TRect;
  public
    constructor Create(Region: TJclRegion);
    destructor Destroy; override;
    property Box: TRect read GetBox;
    property Rectangles[Index: Integer]: TRect read GetRect;
    property Count: Integer read GetCount;
  end;

  TJclRegion = class(TObject)
  private
    FHandle: HRGN;
    FBoxRect: TRect;
    FRegionType: Integer;
    FOwnsHandle: Boolean;
    procedure CheckHandle;
  protected
    function GetHandle: HRGN;
    function GetBox: TRect;
    function GetRegionType: TJclRegionKind;
  public
    constructor Create(RegionHandle: HRGN; OwnsHandle: Boolean = True);
    constructor CreateElliptic(const ARect: TRect); overload;
    constructor CreateElliptic(const Top, Left, Bottom, Right: Integer); overload;
    constructor CreatePoly(const Points: TDynPointArray; Count: Integer; FillMode: TPolyFillMode);
    constructor CreatePolyPolygon(const Points: TDynPointArray; const Vertex: TDynIntegerArray;
      Count: Integer; FillMode: TPolyFillMode);
    constructor CreateRect(const ARect: TRect; DummyForBCB: Boolean = False); overload;
    constructor CreateRect(const Top, Left, Bottom, Right: Integer; DummyForBCB: Byte = 0); overload;
    constructor CreateRoundRect(const ARect: TRect; CornerWidth, CornerHeight: Integer); overload;
    constructor CreateRoundRect(const Top, Left, Bottom, Right, CornerWidth, CornerHeight: Integer); overload;
    constructor CreateBitmap(Bitmap: TBitmap; RegionColor: TColor; RegionBitmapMode: TJclRegionBitmapMode);
    constructor CreatePath(Canvas: TCanvas);
    constructor CreateRegionInfo(RegionInfo: TJclRegionInfo);
    destructor Destroy; override;
    procedure Clip(Canvas: TCanvas);
    procedure Combine(DestRegion, SrcRegion: TJclRegion; CombineOp: TJclRegionCombineOperator); overload;
    procedure Combine(SrcRegion: TJclRegion; CombineOp: TJclRegionCombineOperator); overload;
    function Copy: TJclRegion;
    function Equals(CompareRegion: TJclRegion): Boolean;
    procedure Fill(Canvas: TCanvas);
    procedure FillGradient(Canvas: TCanvas; ColorCount: Integer; StartColor, EndColor: TColor; ADirection: TGradientDirection);
    procedure Frame(Canvas: TCanvas; FrameWidth, FrameHeight: Integer);
    procedure Invert(Canvas: TCanvas);
    procedure Offset(X, Y: Integer);
    procedure Paint(Canvas: TCanvas);
    function PointIn(X, Y: Integer): Boolean; overload;
    function PointIn(const Point: TPoint): Boolean; overload;
    function RectIn(const ARect: TRect): Boolean; overload;
    function RectIn(Top, Left, Bottom, Right: Integer): Boolean; overload;
    procedure SetWindow(Window: HWND; Redraw: Boolean);
    function GetRegionInfo: TJclRegionInfo;
    property Box: TRect read GetBox;
    property Handle: HRGN read GetHandle;
    property RegionType: TJclRegionKind read GetRegionType;
  end;
  {$ENDIF VCL}

  {$IFDEF Bitmap32}
  { TJclThreadPersistent }
  { TJclThreadPersistent is an ancestor for TJclBitmap32 object. In addition to
    TPersistent methods, it provides thread-safe locking and change notification }
  TJclThreadPersistent = class(TPersistent)
  private
    {$IFDEF VCL}
    FLock: TRTLCriticalSection;
    {$ELSE VCL}
    FLock: TCriticalSection;
    {$ENDIF VCL}
    FLockCount: Integer;
    FUpdateCount: Integer;
    FOnChanging: TNotifyEvent;
    FOnChange: TNotifyEvent;
  protected
    property LockCount: Integer read FLockCount;
    property UpdateCount: Integer read FUpdateCount;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Changing; virtual;
    procedure Changed; virtual;
    procedure BeginUpdate;
    procedure EndUpdate;
    procedure Lock;
    procedure Unlock;
    property OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
    property OnChange: TNotifyEvent read FOnChange write FOnChange;
  end;

  { TJclCustomMap }
  { An ancestor for bitmaps and similar 2D distributions which have width and
    height properties }
  TJclCustomMap = class(TJclThreadPersistent)
  private
    FHeight: Integer;
    FWidth: Integer;
    procedure SetHeight(NewHeight: Integer);
    procedure SetWidth(NewWidth: Integer);
  public
    procedure Delete; virtual;
    function  Empty: Boolean; virtual;
    procedure SetSize(Source: TPersistent); overload;
    procedure SetSize(NewWidth, NewHeight: Integer); overload; virtual;
    property Height: Integer read FHeight write SetHeight;
    property Width: Integer read FWidth write SetWidth;
  end;

  { TJclBitmap32 }
  { The TJclBitmap32 class is responsible for storage of a bitmap, as well as for drawing in it }
  TJclBitmap32 = class(TJclCustomMap)
  private
    FBitmapInfo: TBitmapInfo;
    FBits: PColor32Array;
    FDrawMode: TDrawMode;
    FFont: TFont;
    FHandle: HBITMAP;
    FHDC: HDC;
    FMasterAlpha: Byte;
    FOuterColor: TColor32; // the value returned when accessing outer areas
    FPenColor: TColor32;
    FStippleCounter: Single;
    FStipplePattern: TArrayOfColor32;
    FStippleStep: Single;
    FStretchFilter: TStretchFilter;
    function  GetPixel(X, Y: Integer): TColor32;
    function  GetPixelS(X, Y: Integer): TColor32;
    function  GetPixelPtr(X, Y: Integer): PColor32;
    function  GetScanLine(Y: Integer): PColor32Array;
    procedure SetDrawMode(Value: TDrawMode);
    procedure SetFont(Value: TFont);
    procedure SetMasterAlpha(Value: Byte);
    procedure SetPixel(X, Y: Integer; Value: TColor32);
    procedure SetPixelS(X, Y: Integer; Value: TColor32);
    procedure SetStippleStep(Value: Single);
    procedure SetStretchFilter(Value: TStretchFilter);
  protected
    FontHandle: HFont;
    RasterX: Integer;
    RasterY: Integer;
    RasterXF: Single;
    RasterYF: Single;
    procedure AssignTo(Dst: TPersistent); override;
    function  ClipLine(var X0, Y0, X1, Y1: Integer): Boolean;
    class function ClipLineF(var X0, Y0, X1, Y1: Single; MinX, MaxX, MinY, MaxY: Single): Boolean;
    procedure FontChanged(Sender: TObject);
    procedure SET_T256(X, Y: Integer; C: TColor32);
    procedure SET_TS256(X, Y: Integer; C: TColor32);
    procedure ReadData(Stream: TStream); virtual;
    procedure WriteData(Stream: TStream); virtual;
    procedure DefineProperties(Filer: TFiler); override;
    property StippleCounter: Single read FStippleCounter;
  public
    constructor Create; override;
    destructor Destroy; override;

    procedure Assign(Source: TPersistent); override;
    procedure SetSize(NewWidth, NewHeight: Integer); override;
    function  Empty: Boolean; override;
    procedure Clear; overload;
    procedure Clear(FillColor: TColor32); overload;
    procedure Delete; override;

    procedure LoadFromStream(Stream: TStream);
    procedure SaveToStream(Stream: TStream);
    procedure LoadFromFile(const FileName: string);
    procedure SaveToFile(const FileName: string);

    procedure ResetAlpha;

    procedure Draw(DstX, DstY: Integer; Src: TJclBitmap32); overload;
    procedure Draw(DstRect, SrcRect: TRect; Src: TJclBitmap32); overload;
    procedure Draw(DstRect, SrcRect: TRect; hSrc: HDC); overload;

    procedure DrawTo(Dst: TJclBitmap32); overload;
    procedure DrawTo(Dst: TJclBitmap32; DstX, DstY: Integer); overload;
    procedure DrawTo(Dst: TJclBitmap32; DstRect: TRect); overload;
    procedure DrawTo(Dst: TJclBitmap32; DstRect, SrcRect: TRect); overload;
    procedure DrawTo(hDst: HDC; DstX, DstY: Integer); overload;
    procedure DrawTo(hDst: HDC; DstRect, SrcRect: TRect); overload;

    function  GetPixelB(X, Y: Integer): TColor32;
    procedure SetPixelT(X, Y: Integer; Value: TColor32); overload;
    procedure SetPixelT(var Ptr: PColor32; Value: TColor32); overload;
    procedure SetPixelTS(X, Y: Integer; Value: TColor32);
    procedure SetPixelF(X, Y: Single; Value: TColor32);
    procedure SetPixelFS(X, Y: Single; Value: TColor32);

    procedure SetStipple(NewStipple: TArrayOfColor32); overload;
    procedure SetStipple(NewStipple: array of TColor32); overload;
    procedure ResetStippleCounter;
    function  GetStippleColor: TColor32;

    procedure DrawHorzLine(X1, Y, X2: Integer; Value: TColor32);
    procedure DrawHorzLineS(X1, Y, X2: Integer; Value: TColor32);
    procedure DrawHorzLineT(X1, Y, X2: Integer; Value: TColor32);
    procedure DrawHorzLineTS(X1, Y, X2: Integer; Value: TColor32);
    procedure DrawHorzLineTSP(X1, Y, X2: Integer);

    procedure DrawVertLine(X, Y1, Y2: Integer; Value: TColor32);
    procedure DrawVertLineS(X, Y1, Y2: Integer; Value: TColor32);
    procedure DrawVertLineT(X, Y1, Y2: Integer; Value: TColor32);
    procedure DrawVertLineTS(X, Y1, Y2: Integer; Value: TColor32);
    procedure DrawVertLineTSP(X, Y1, Y2: Integer);

    procedure DrawLine(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineT(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineTS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineA(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineAS(X1, Y1, X2, Y2: Integer; Value: TColor32; L: Boolean = False);
    procedure DrawLineF(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False);
    procedure DrawLineFS(X1, Y1, X2, Y2: Single; Value: TColor32; L: Boolean = False);
    procedure DrawLineFP(X1, Y1, X2, Y2: Single; L: Boolean = False);
    procedure DrawLineFSP(X1, Y1, X2, Y2: Single; L: Boolean = False);

    procedure MoveTo(X, Y: Integer);
    procedure LineToS(X, Y: Integer);
    procedure LineToTS(X, Y: Integer);
    procedure LineToAS(X, Y: Integer);
    procedure MoveToF(X, Y: Single);
    procedure LineToFS(X, Y: Single);

    procedure FillRect(X1, Y1, X2, Y2: Integer; Value: TColor32);
    procedure FillRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
    procedure FillRectT(X1, Y1, X2, Y2: Integer; Value: TColor32);
    procedure FillRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32);

    procedure FrameRectS(X1, Y1, X2, Y2: Integer; Value: TColor32);
    procedure FrameRectTS(X1, Y1, X2, Y2: Integer; Value: TColor32); overload;
    procedure FrameRectTSP(X1, Y1, X2, Y2: Integer); overload;
    procedure RaiseRectTS(X1, Y1, X2, Y2: Integer; Contrast: Integer);

    procedure UpdateFont;
    procedure TextOut(X, Y: Integer; const Text: string); overload;
    procedure TextOut(X, Y: Integer; const ClipRect: TRect; const Text: string); overload;
    procedure TextOut(ClipRect: TRect; const Flags: Cardinal; const Text: string); overload;
    function  TextExtent(const Text: string): TSize;
    function  TextHeight(const Text: string): Integer;
    function  TextWidth(const Text: string): Integer;
    procedure RenderText(X, Y: Integer; const Text: string; AALevel: Integer; Color: TColor32);

    property BitmapHandle: HBITMAP read FHandle;
    property BitmapInfo: TBitmapInfo read FBitmapInfo;
    property Bits: PColor32Array read FBits;
    property Font: TFont read FFont write SetFont;
    property Handle: HDC read FHDC;
    property PenColor: TColor32 read FPenColor write FPenColor;
    property Pixel[X, Y: Integer]: TColor32 read GetPixel write SetPixel; default;
    property PixelS[X, Y: Integer]: TColor32 read GetPixelS write SetPixelS;
    property PixelPtr[X, Y: Integer]: PColor32 read GetPixelPtr;
    property ScanLine[Y: Integer]: PColor32Array read GetScanLine;
    property StippleStep: Single read FStippleStep write SetStippleStep;
  published
    property DrawMode: TDrawMode read FDrawMode write SetDrawMode default dmOpaque;
    property MasterAlpha: Byte read FMasterAlpha write SetMasterAlpha default $FF;
    property OuterColor: TColor32 read FOuterColor write FOuterColor default 0;
    property StretchFilter: TStretchFilter read FStretchFilter write SetStretchFilter default sfNearest;
    property OnChanging;
    property OnChange;
  end;

  TJclByteMap = class(TJclCustomMap)
  private
    FBytes: TDynByteArray;
    FHeight: Integer;
    FWidth: Integer;
    function GetValue(X, Y: Integer): Byte;
    function GetValPtr(X, Y: Integer): PByte;
    procedure SetValue(X, Y: Integer; Value: Byte);
  protected