_graphics.pas

East make Tray Icon in delphi

    procedure AssignTo(Dst: TPersistent); override;
  public
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    function  Empty: Boolean; override;
    procedure Clear(FillValue: Byte);
    procedure ReadFrom(Source: TJclBitmap32; Conversion: TConversionKind);
    procedure SetSize(NewWidth, NewHeight: Integer); override;
    procedure WriteTo(Dest: TJclBitmap32; Conversion: TConversionKind); overload;
    procedure WriteTo(Dest: TJclBitmap32; const Palette: TPalette32); overload;
    property Bytes: TDynByteArray read FBytes;
    property ValPtr[X, Y: Integer]: PByte read GetValPtr;
    property Value[X, Y: Integer]: Byte read GetValue write SetValue; default;
  end;
  {$ENDIF Bitmap32}

  TJclTransformation = class(TObject)
  public
    function  GetTransformedBounds(const Src: TRect): TRect; virtual; abstract;
    procedure PrepareTransform; virtual; abstract;
    procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); virtual; abstract;
    procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); virtual; abstract;
  end;

  TJclLinearTransformation = class(TJclTransformation)
  private
    FMatrix: TMatrix3d;
  protected
    A: Integer;
    B: Integer;
    C: Integer;
    D: Integer;
    E: Integer;
    F: Integer;
  public
    constructor Create; virtual;
    function  GetTransformedBounds(const Src: TRect): TRect; override;
    procedure PrepareTransform; override;
    procedure Transform(DstX, DstY: Integer; out SrcX, SrcY: Integer); override;
    procedure Transform256(DstX, DstY: Integer; out SrcX256, SrcY256: Integer); override;
    procedure Clear;
    procedure Rotate(Cx, Cy, Alpha: Extended); // degrees
    procedure Skew(Fx, Fy: Extended);
    procedure Scale(Sx, Sy: Extended);
    procedure Translate(Dx, Dy: Extended);
    property Matrix: TMatrix3d read FMatrix write FMatrix;
  end;

// Bitmap Functions
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Source: TGraphic; Target: TBitmap); overload;
procedure Stretch(NewWidth, NewHeight: Cardinal; Filter: TResamplingFilter;
  Radius: Single; Bitmap: TBitmap); overload;

{$IFDEF MSWINDOWS}
procedure DrawBitmap(DC: HDC; Bitmap: HBITMAP; X, Y, Width, Height: Integer);

function ExtractIconCount(const FileName: string): Integer;
function BitmapToIcon(Bitmap: HBITMAP; cx, cy: Integer): HICON;
function IconToBitmap(Icon: HICON): HBITMAP;
{$ENDIF MSWINDOWS}

{$IFDEF VCL}
procedure BitmapToJPeg(const FileName: string);
procedure JPegToBitmap(const FileName: string);

procedure SaveIconToFile(Icon: HICON; const FileName: string);
procedure WriteIcon(Stream: TStream; ColorBitmap, MaskBitmap: HBITMAP;
  WriteLength: Boolean = False); overload;
procedure WriteIcon(Stream: TStream; Icon: HICON; WriteLength: Boolean = False); overload;
procedure GetIconFromBitmap(Icon: TIcon; Bitmap: TBitmap);

function GetAntialiasedBitmap(const Bitmap: TBitmap): TBitmap;
{$ENDIF VCL}

{$IFDEF Bitmap32}
procedure BlockTransfer(Dst: TJclBitmap32; DstX: Integer; DstY: Integer; Src: TJclBitmap32;
  SrcRect: TRect; CombineOp: TDrawMode);

procedure StretchTransfer(Dst: TJclBitmap32; DstRect: TRect; Src: TJclBitmap32; SrcRect: TRect;
  StretchFilter: TStretchFilter; CombineOp: TDrawMode);

procedure Transform(Dst, Src: TJclBitmap32; SrcRect: TRect; Transformation: TJclTransformation);
procedure SetBorderTransparent(ABitmap: TJclBitmap32; ARect: TRect);
{$ENDIF Bitmap32}

{$IFDEF MSWINDOWS}
function FillGradient(DC: HDC; ARect: TRect; ColorCount: Integer;
  StartColor, EndColor: TColor; ADirection: TGradientDirection): Boolean; overload;
{$ENDIF MSWINDOWS}

{$IFDEF VCL}
function CreateRegionFromBitmap(Bitmap: TBitmap; RegionColor: TColor;
  RegionBitmapMode: TJclRegionBitmapMode): HRGN;
procedure ScreenShot(bm: TBitmap; Left, Top, Width, Height: Integer; Window: HWND = HWND_DESKTOP); overload;
procedure ScreenShot(bm: TBitmap; IncludeTaskBar: Boolean = True); overload;
{$ENDIF VCL}

{$IFDEF Bitmap32}
// PolyLines and Polygons
procedure PolyLineTS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolyLineAS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolyLineFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF; Color: TColor32);

procedure PolygonTS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolygonAS(Bitmap: TJclBitmap32; const Points: TDynPointArray; Color: TColor32);
procedure PolygonFS(Bitmap: TJclBitmap32; const Points: TDynPointArrayF; Color: TColor32);

procedure PolyPolygonTS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
  Color: TColor32);
procedure PolyPolygonAS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArray;
  Color: TColor32);
procedure PolyPolygonFS(Bitmap: TJclBitmap32; const Points: TDynDynPointArrayArrayF;
  Color: TColor32);

// Filters
procedure AlphaToGrayscale(Dst, Src: TJclBitmap32);
procedure IntensityToAlpha(Dst, Src: TJclBitmap32);
procedure Invert(Dst, Src: TJclBitmap32);
procedure InvertRGB(Dst, Src: TJclBitmap32);
procedure ColorToGrayscale(Dst, Src: TJclBitmap32);
procedure ApplyLUT(Dst, Src: TJclBitmap32; const LUT: TLUT8);
procedure SetGamma(Gamma: Single = 0.7);
{$ENDIF Bitmap32}

implementation

uses
  Math,
  {$IFDEF MSWINDOWS}
  CommCtrl, ShellApi,
  {$IFDEF VCL}
  ClipBrd, JPeg, TypInfo,
  JclResources,
  {$ENDIF VCL}
  {$ENDIF MSWINDOWS}
  JclLogic;

type
  TRGBInt = record
    R: Integer;
    G: Integer;
    B: Integer;
  end;

  PBGRA = ^TBGRA;
  TBGRA = packed record
    B: Byte;
    G: Byte;
    R: Byte;
    A: Byte;
  end;

  PPixelArray = ^TPixelArray;
  TPixelArray = array [0..0] of TBGRA;

  TBitmapFilterFunction = function(Value: Single): Single;

  PContributor = ^TContributor;
  TContributor = record
   Weight: Integer; // Pixel Weight
   Pixel: Integer;  // Source Pixel
  end;

  TContributors = array of TContributor;

  // list of source pixels contributing to a destination pixel
  TContributorEntry = record
   N: Integer;
   Contributors: TContributors;
  end;

  TContributorList = array of TContributorEntry;
  TJclGraphicAccess = class(TGraphic);

const
  DefaultFilterRadius: array [TResamplingFilter] of Single =
    (0.5, 1.0, 1.0, 1.5, 2.0, 3.0, 2.0);
  _RGB: TColor32 = $00FFFFFF;

var
  { Gamma bias for line/pixel antialiasing/shape correction }
  GAMMA_TABLE: TGamma;

threadvar
  // globally used cache for current image (speeds up resampling about 10%)
  CurrentLineR: array of Integer;
  CurrentLineG: array of Integer;
  CurrentLineB: array of Integer;

//=== Helper functions =======================================================

function IntToByte(Value: Integer): Byte;
begin
  Result := Math.Max(0, Math.Min(255, Value));
end;

{$IFDEF Bitmap32}

procedure CheckBitmaps(Dst, Src: TJclBitmap32);
begin
  if (Dst = nil) or Dst.Empty then
    raise EJclGraphicsError.CreateRes(@RsDestinationBitmapEmpty);
  if (Src = nil) or Src.Empty then
    raise EJclGraphicsError.CreateRes(@RsSourceBitmapEmpty);
end;

function CheckSrcRect(Src: TJclBitmap32; const SrcRect: TRect): Boolean;
begin
  Result := False;
  if IsRectEmpty(SrcRect) then
    Exit;
  if (SrcRect.Left < 0) or (SrcRect.Right > Src.Width) or
    (SrcRect.Top < 0) or (SrcRect.Bottom > Src.Height) then
    raise EJclGraphicsError.CreateRes(@RsSourceBitmapInvalid);
  Result := True;
end;

{$ENDIF Bitmap32}

//=== Internal low level routines ============================================

procedure FillLongword(var X; Count: Integer; Value: Longword);
{asm
// EAX = X
// EDX = Count
// ECX = Value
        TEST    EDX, EDX
        JLE     @@EXIT

        PUSH    EDI
        MOV     EDI, EAX  // Point EDI to destination
        MOV     EAX, ECX
        MOV     ECX, EDX
        REP     STOSD    // Fill count dwords
        POP     EDI
@@EXIT:
end;}
var
  P: PLongword;
begin
  P := @X;
  while Count > 0 do
  begin
    P^ := Value;
    Inc(P);
    Dec(Count);
  end;
end;

function Clamp(Value: Integer): TColor32;
begin
  if Value < 0 then
    Result := 0
  else
  if Value > 255 then
    Result := 255
  else
    Result := Value;
end;

procedure TestSwap(var A, B: Integer);
{asm
// EAX = [A]
// EDX = [B]
        MOV     ECX, [EAX]     // ECX := [A]
        CMP     ECX, [EDX]     // ECX <= [B]? Exit
        JLE     @@EXIT
        //Replaced on more fast code
        //XCHG    ECX, [EDX]     // ECX <-> [B];
        //MOV     [EAX], ECX     // [A] := ECX
        PUSH    EBX
        MOV     EBX,[EDX]      // EBX := [B]
        MOV     [EAX],EBX      // [A] := EBX
        MOV     [EDX],ECX      // [B] := ECX
        POP     EBX
@@EXIT:
end;}
var
  X: Integer;
begin
  X := A; // optimization
  if X > B then
  begin
    A := B;
    B := X;
  end;
end;

function TestClip(var A, B: Integer; Size: Integer): Boolean;
begin
  TestSwap(A, B); // now A = min(A,B) and B = max(A, B)
  if A < 0 then
    A := 0;
  if B >= Size then
    B := Size - 1;
  Result := B >= A;
end;

function Constrain(Value, Lo, Hi: Integer): Integer;
begin
  if Value <= Lo then
    Result := Lo
  else
  if Value >= Hi then
    Result := Hi
  else
    Result := Value;
end;

// Filter functions for stretching of TBitmaps
// f(t) = 2|t|^3 - 3|t|^2 + 1, -1 <= t <= 1

function BitmapHermiteFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1 then
    Result := (2 * Value - 3) * Sqr(Value) + 1
  else
    Result := 0;
end;

// This filter is also known as 'nearest neighbour' Filter.

function BitmapBoxFilter(Value: Single): Single;
begin
  if (Value > -0.5) and (Value <= 0.5) then
    Result := 1.0
  else
    Result := 0.0;
end;

// aka 'linear' or 'bilinear' filter

function BitmapTriangleFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
    Result := 1.0 - Value
  else
    Result := 0.0;
end;

function BitmapBellFilter(Value: Single): Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 0.5 then
    Result := 0.75 - Sqr(Value)
  else
  if Value < 1.5 then
  begin
    Value := Value - 1.5;
    Result := 0.5 * Sqr(Value);
  end
  else
    Result := 0.0;
end;

// B-spline filter

function BitmapSplineFilter(Value: Single): Single;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 1.0 then
  begin
    Temp := Sqr(Value);
    Result := 0.5 * Temp * Value - Temp + 2.0 / 3.0;
  end
  else
  if Value < 2.0 then
  begin
    Value := 2.0 - Value;
    Result := Sqr(Value) * Value / 6.0;
  end
  else
    Result := 0.0;
end;

function BitmapLanczos3Filter(Value: Single): Single;

  function SinC(Value: Single): Single;
  begin
    if Value <> 0.0 then
    begin
      Value := Value * Pi;
      Result := System.Sin(Value) / Value;
    end
    else
      Result := 1.0;
  end;

begin
  if Value < 0.0 then
    Value := -Value;
  if Value < 3.0 then
    Result := SinC(Value) * SinC(Value / 3.0)
  else
    Result := 0.0;
end;

function BitmapMitchellFilter(Value: Single): Single;
const
  B = 1.0 / 3.0;
  C = 1.0 / 3.0;
var
  Temp: Single;
begin
  if Value < 0.0 then
    Value := -Value;
  Temp := Sqr(Value);
  if Value < 1.0 then
  begin
    Value := (((12.0 - 9.0 * B - 6.0 * C) * (Value * Temp)) +
      ((-18.0 + 12.0 * B + 6.0 * C) * Temp) +