sgraphutils.pas

Alpha Controls.v5.46b Source

unit sGraphUtils;
{$I sDefs.inc}
{$DEFINE DEBAGASM8} // Improving of blending
{.$DEFINE LOGGED}

interface

//  Result := ((Src1 - Src2) * PercentOfSrc1 + Src2 shl 8) shr 8; PercentOfSrc1 is a integer between 0 and 255
//  Result := Round((Src1 - Src2) * PercentOfSrc1 + Src2); PercentOfSrc1 is a real value between 0 and 1

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  {$IFDEF TNTUNICODE}TntGraphics, {$ENDIF}
  ComCtrls, sConst, ExtCtrls, Jpeg, acntUtils, math, Buttons{$IFDEF LOGGED}, sDebugMsgs{$ENDIF}
  {$IFNDEF ACHINTS}, imglist, sMaskData, sCommonData{$ENDIF};

{$IFNDEF NOTFORHELP}
type
  TsHSV = record h : integer; s : real; v : real end;

var
  CtrlParentColor : TColor = clFuchsia;
  ParentCenterColor : TColor = clFuchsia;

{$ENDIF} // NOTFORHELP

function SwapColor(i : integer) : integer;
function ColorToSColor(Color : TColor) : TsColor;
// Paint tiled TGraphic on bitmap
procedure TileBitmap(Canvas: TCanvas; aRect: TRect; Graphic: TGraphic); overload;

{$IFNDEF ACHINTS}
procedure RGBToHSV (const R, G, B: Real; var H, S, V: Real);
procedure HSVtoRGB (const H,S,V: Real; var R,G,B: real);
procedure CopyImage(Glyph : TBitmap; ImageList: TCustomImageList; Index: Integer);
procedure PaintItemBG(SkinData : TsCommonData; ci : TCacheInfo; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; OffsetX : integer = 0; OffsetY : integer = 0); overload;
procedure PaintItem(SkinData : TsCommonData; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; UpdateCorners : boolean; OffsetX : integer = 0; OffsetY : integer = 0); overload;

procedure DrawGlyphEx(Glyph, DstBmp : TBitmap; R : TRect; NumGlyphs : integer; Enabled, Grayed : boolean; DisabledGlyphKind : TsDisabledGlyphKind; State, Blend : integer; Down : boolean = False);
{$ENDIF}
// Fills rectangle on device context by Color
procedure FillDC(DC: HDC; aRect: TRect; Color: TColor);
procedure BitBltBorder(DestDC: HDC; X, Y, Width, Height: Integer; SrcDC: HDC; XSrc, YSrc: Integer; BorderWidth : integer);
// Grayscale bitmap
procedure GrayScale(Bmp: TBitmap);
procedure GrayScaleTrans(Bmp: TBitmap; const TransColor : TsColor);
// Draws glyph for sCheckBox DEPRECATED in v5
procedure PaintCheck(Canvas: TCanvas; r: TRect; Enabled: boolean; Color: TColor);
// Function CutText get text with ellipsis if no enough place
function CutText(Canvas: TCanvas; const Text: string; MaxLength : integer): string;
// Writes text on Canvas on custom rectangle by Flags
procedure WriteText(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal);
procedure SumBitmaps(SrcBmp, MskBmp: Graphics.TBitMap; Color : TsColor);
procedure SumBmpRect(DstBmp, SrcBmp: Graphics.TBitMap; Color : TsColor; SrcRect : TRect; DstPoint : TPoint);
// Alpha-blending of rectangle on bitmap by Blend, excluding pixels with color TransColor
// if TransColor.A = 255 then TransColor is not used
procedure BlendTransRectangle(Dst: TBitmap; X, Y: integer; Src: TBitmap; aRect: TRect; Blend: real; TransColor: TsColor);
procedure BlendTransBitmap(Bmp: TBitmap; Blend: real; Color, TransColor: TsColor);
// Alpha-blending of rectangle on bitmap custom transparency, color, blur and radius
procedure FadeBmp(FadedBmp: TBitMap; aRect: TRect;Transparency: integer; Color: TsColor; Blur, Radius : integer);
// Copying alpha-blended rectangle from CanvasSrc to CanvasDst
procedure FadeRect(CanvasSrc: TCanvas; RSrc: TRect; CanvasDst: HDC; PDst: TPoint; Transparency: integer; Color: TColor; Blur : integer; Shape: TsShadowingShape); overload;
procedure FadeRect(CanvasSrc: TCanvas; RSrc: TRect; CanvasDst: HDC; PDst: TPoint; Transparency: integer; Color: TColor; Blur : integer; Shape: TsShadowingShape; Radius : integer); overload;
// Sum two bitmaps where Color used as mask
procedure BlendBmpByMask(SrcBmp, MskBmp: Graphics.TBitMap; BlendColor : TsColor);
// Copying rectangle from SrcBmp to DstBmp
procedure CopyRect(DstBmp, SrcBmp: Graphics.TBitMap; X, Y : integer; aRect: TRect; TransColor : TColor);
// Copying bitmap SrcBmp to DstBmp, excluding pixels with color TransColor
procedure CopyTransBitmaps(DstBmp, SrcBmp: Graphics.TBitMap; X, Y : integer; TransColor : TsColor);
// Sum two bitmaps by mask MskBmp
procedure SumByMask(var Src1, Src2, MskBmp: Graphics.TBitMap; aRect: TRect);
// Fills bitmap by custom properties of Gradient
procedure GradientBmp(Bmp: Graphics.TBitMap; aRect : TRect; Color1, Color2 : TsColor; Layout : TGradientTypes; Percent1, Percent2 : TPercent; Width : integer);
// Returns color as ColorBegin -  (ColorBegin - ColorEnd) * i
function ChangeColor(ColorBegin, ColorEnd : TColor; i : real) : TColor;
// Returns color as (ColorBegin + ColorEnd) / 2
function AverageColor(ColorBegin, ColorEnd : TsColor) : TsColor; overload;
function AverageColor(ColorBegin, ColorEnd : TColor) : TColor; overload;
function MixColors(Color1, Color2 : TColor; PercentOfColor1 : real) : TColor;
// Draws rectangle on device context
procedure DrawRectangleOnDC(DC: HDC; var R: TRect; ColorTop, ColorBottom: TColor; var Width: integer);
procedure CalcButtonLayout(const Client: TRect; const GlyphSize: TPoint; const TextRectSize: TSize; Layout: TButtonLayout;
            Alignment: TAlignment; Margin, Spacing: Integer; var GlyphPos: TPoint; var TextBounds: TRect; BiDiFlags: LongInt);      {RL}
// Returns height of font
function GetFontHeight(hFont : HWnd): integer;
// Returns width of text
function GetStringSize(hFont : hgdiobj; const Text : acString): TSize;
// Loads to Image TJpegImage or TBitmap from FileName
function LoadJpegOrBmp(Image: TPicture; const FileName: string; Gray: boolean):boolean;
procedure FocusRect(Canvas : TCanvas; R : TRect);

{$IFNDEF NOTFORHELP}
{$IFNDEF ACHINTS}
procedure TileBitmap(Canvas: TCanvas; var aRect: TRect; Graphic: TGraphic; MaskData : TsMaskData; FillMode : TacFillMode = fmTiled); overload;
procedure TileBitmapFromOther(Canvas: TCanvas; aRect: TRect; MaskData : TsMaskData);
procedure TileMasked(Bmp: TBitmap; var aRect: TRect; CI : TCacheInfo; MaskData : TsMaskData; FillMode : TacFillMode = fmDisTiled);
procedure AddRgn(var AOR : TAOR; Width : integer; MaskData : TsMaskData; VertOffset : integer; Bottom : boolean);
function GetRgnForMask(MaskIndex, Width, Height : integer; SkinManager : TObject) : hrgn;
procedure GetRgnFromBmp(var rgn : hrgn; MaskBmp : TBitmap; TransColor : TColor);
procedure AddRgnBmp(var AOR : TAOR; MaskBmp : TBitmap; TransColor : TsColor);
{$ENDIF}
procedure SumBitmapsByMask(var ResultBmp, Src1, Src2: Graphics.TBitMap; MskBmp: Graphics.TBitMap; Percent : word = 0);
// Copy Bmp with AlphaMask if Bmp2 is not MasterBitmap
procedure CopyByMask(R1, R2 : TRect; Bmp1, Bmp2 : TBitmap; CI : TCacheInfo; UpdateTrans : boolean); overload;
procedure CopyByMask(R1, R2 : TRect; Bmp1, Bmp2 : TBitmap; CI : TCacheInfo; UpdateTrans : boolean; MaskData : TsMaskData); overload;
// Copying rectangle from SrcBmp to DstBmp, excluding pixels with color TransColor (get trans pixels from parent)
procedure CopyTransRect(DstBmp, SrcBmp: Graphics.TBitMap; X, Y : integer; SrcRect: TRect; TransColor : TColor; CI : TCacheInfo; UpdateTrans : boolean);
// Skip transarent part
procedure CopyTransRectA(DstBmp, SrcBmp: Graphics.TBitMap; X, Y : integer; SrcRect: TRect; TransColor : TColor; CI : TCacheInfo);
// Creates bitmap like Bmp
function CreateBmpLike(Bmp: TBitmap): TBitmap;
function CreateBmp24(Width, Height : integer) : TBitmap;
function CreateBmp32(Width, Height : integer) : TBitmap;
procedure InitCI(var CI : TCacheInfo; Bmp : TBitmap; X : integer = 0; y : integer = 0);
procedure WriteTextOnDC(DC: hdc; Text: PChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal);
function acDrawText(hDC: HDC; const Text: ACString; var lpRect: TRect; uFormat: Cardinal): Integer;
function acTextWidth(Canvas: TCanvas; const Text: ACString): Integer;
function acTextHeight(Canvas: TCanvas; const Text: ACString): Integer;
function acTextExtent(Canvas: TCanvas; const Text: ACString): TSize;
procedure acTextRect(Canvas : TCanvas; const Rect: TRect; X, Y: Integer; const Text: ACString);

procedure acWriteTextEx(Canvas: TCanvas; Text: PacChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinData : TsCommonData; Hot : boolean; SkinManager : TObject = nil); overload;
procedure acWriteTextEx(Canvas: TCanvas; Text: PacChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinIndex : integer; Hot : boolean; SkinManager : TObject = nil); overload;
procedure acWriteText(Canvas: TCanvas; Text: PacChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal);

{$IFNDEF ACHINTS}
procedure WriteTextEx(Canvas: TCanvas; Text: PAnsiChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinIndex : integer; Hot : boolean; SkinManager : TObject = nil); overload;
procedure WriteTextEx(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinData : TsCommonData; Hot : boolean); overload;
{$IFDEF TNTUNICODE}
procedure WriteUnicode(Canvas: TCanvas; const Text: WideString; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinData : TsCommonData; Hot : boolean); overload;
procedure WriteTextExW(Canvas: TCanvas; Text: PWideChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinData : TsCommonData; Hot : boolean); overload;
// replace function of Canvas.TextRect
procedure TextRectW(Canvas : TCanvas; Rect: TRect; X, Y: Integer; const Text: WideString);
procedure WriteTextExW(Canvas: TCanvas; Text: PWideChar; Enabled: boolean; var aRect : TRect; Flags: Cardinal; SkinIndex : integer; Hot : boolean; SkinManager : TObject = nil); overload;
{$ENDIF}

procedure PaintItemBG(SkinIndex : integer; const SkinSection : string; ci : TCacheInfo; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; SkinManager : TObject = nil; TextureIndex : integer = -1; HotTextureIndex : integer = -1; CustomColor : TColor = clFuchsia); overload;
procedure PaintItemBGFast(SkinIndex, BGIndex, BGHotIndex : integer; const SkinSection : string; ci : TCacheInfo; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; SkinManager : TObject = nil);
procedure PaintItemFast(SkinIndex, MaskIndex, BGIndex, BGHotIndex : integer; const SkinSection : string; var ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; SkinManager : TObject = nil); overload;
procedure PaintSmallItem(SkinIndex : integer; const SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; SkinManager : TObject = nil); overload;
procedure PaintItem(SkinIndex : integer; const SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap; SkinManager : TObject = nil; BGIndex : integer = -1; BGHotIndex : integer = -1); overload;
procedure PaintItem(SkinIndex : integer; const SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; DC : HDC; SkinManager : TObject = nil); overload;

//function ChangeHue(Delta : integer; C : TsColor) : TsColor; overload;
function ChangeBrightness(Color : TColor; Delta : integer) : TColor;
function ChangeSaturation(Color : TColor; Delta : integer) : TColor;
function ChangeHue(Delta : integer; Color : TColor) : TColor; overload;
//function ChangeHLS(Color : TColor; dH, dL, dS : integer) : TColor; overload;
function Hsv2Rgb(h, s, v : real) : TsColor;
function Rgb2Hsv(C : TsColor) : TsHSV;
{$ENDIF}

var
  UpdateLayeredWindow: function (Handle: THandle; hdcDest: HDC; pptDst: PPoint; _psize: PSize;
    hdcSrc: HDC; pptSrc: PPoint; crKey: COLORREF; pblend: PBLENDFUNCTION; dwFlags: DWORD): Boolean; stdcall;

{$ENDIF} // NOTFORHELP
implementation

uses {$IFNDEF ACHINTS}sStyleSimply, sSkinProps, sSkinManager, sBorders, sSkinProvider, sVCLUtils,
  {$ENDIF}sGradient, sAlphaGraph{$IFDEF TNTUNICODE}, TntWideStrUtils, TntWindows{$ENDIF}, sDefaults;

function SwapColor(i : integer) : integer;
var
  r, g, b : integer;
begin
  r := i mod 256;
  i := i shr 8;
  g := i mod 256;
  b := i shr 8;
  Result := r shl 16 + g shl 8 + b;;
end;

{$IFNDEF ACHINTS}
function IsNAN(const d: double): boolean;
var
  Overlay: Int64 absolute d;
begin
  Result := ((Overlay and $7FF0000000000000) = $7FF0000000000000) and ((Overlay and $000FFFFFFFFFFFFF) <> $0000000000000000)
end;

function ChangeBrightness(Color : TColor; Delta : integer) : TColor;
var
  C : TsColor;
  dR, dG, dB : real;
begin
  Result := Color;
  if Delta = 0 then Exit;
  C.C := Color;

  if Delta > 0 then begin
    dR := (255 - C.R) / 100;
    dG := (255 - C.G) / 100;
    dB := (255 - C.B) / 100;
  end
  else begin
    dR := C.R / 100;
    dG := C.G / 100;
    dB := C.B / 100;
  end;

  C.R := max(min(Round(C.R + Delta * dR), 255), 0);
  C.G := max(min(Round(C.G + Delta * dG), 255), 0);
  C.B := max(min(Round(C.B + Delta * dB), 255), 0);
  Result := C.C;
end;

function ChangeSaturation(Color : TColor; Delta : integer) : TColor;
var
  C : TsColor;
  dR, dG, dB, Gray : real;
begin
  Result := Color;
  if Delta = 0 then Exit;
  C.C := Color;

  Gray := (C.R + C.G + C.B) / 3;

  dR := (Gray - C.R) / 100;
  dG := (Gray - C.G) / 100;
  dB := (Gray - C.B) / 100;

  Result := Rgb(max(min(Round(C.R + Delta * dR), 255), 0), max(min(Round(C.G + Delta * dG), 255), 0), max(min(Round(C.B + Delta * dB), 255), 0));
{v4.84
  C.R := max(min(Round(C.R + Delta * dR), 255), 0);
  C.G := max(min(Round(C.G + Delta * dG), 255), 0);
  C.B := max(min(Round(C.B + Delta * dB), 255), 0);
  Result := C.C;
}
end;

function Hsv2Rgb(h, s, v : real) : TsColor;
var
  I : integer;
  F, M, N, K : real;
begin
  if S = 0 then begin Result.R := IntToByte(Round(V * 255)); Result.G := Result.R; Result.B := Result.R end else begin
    if H = 360 then H := 0 else H := H / 60;
    I := Round(Int(H));
    F := (H - I);

    V := V * 255;
    M := V * (1 - S);
    N := V * (1 - S * F);
    K := V * (1 - S * (1 - F));

    M := max(min(M, 255), 0);
    N := max(min(N, 255), 0);
    K := max(min(K, 255), 0);

    Result.A := 0;
    case I of
      0: begin Result.R := Round(V); Result.G := Round(K); Result.B := Round(M) end;
      1: begin Result.R := Round(N); Result.G := Round(V); Result.B := Round(M) end;
      2: begin Result.R := Round(M); Result.G := Round(V); Result.B := Round(K) end;
      3: begin Result.R := Round(M); Result.G := Round(N); Result.B := Round(V) end;
      4: begin Result.R := Round(K); Result.G := Round(M); Result.B := Round(V) end
    else begin Result.R := Round(V); Result.G := Round(M); Result.B := Round(N) end
    end;
  end
end;

function Rgb2Hsv(C : TsColor) : TsHSV;
var
  Rt, Gt, Bt : real;
  H, S, V : real;
  d, max, min : integer;
begin
  C.A := 0;
  max := math.Max(math.Max(c.R, c.G), c.B);
  min := math.Min(math.Min(c.R, c.G), c.B);
  d := max - min;
  V := max;
  if (max <> 0) then S := d / max else S := 0;
  if S = 0 then begin
    Result.H := 0;
  end
  else begin
    rt := max - c.R * 60 / d;
    gt := max - c.G * 60 / d;
    bt := max - c.B * 60 / d;
    if c.R = max then H := bt - gt else if c.G = max then H := 120 + rt - bt else H := 240 + gt - rt;
    if H < 0 then H := H + 360;
    Result.H := Round(H);
  end;
  Result.S := S;
  Result.V := V / 255;//0;
end;

function ChangeHue(Delta : integer; Color : TColor) : TColor; overload;
var
  Rt, Gt, Bt : real;
  H, S, V, r : real;
  d, max, min : integer;
  I : integer;
  F, M, N, K : real;
  C : TsColor;
begin
  C.C := ColorToRGB(Color);
  C.A := 0;
  max := math.Max(math.Max(c.R, c.G), c.B);
  min := math.Min(math.Min(c.R, c.G), c.B);
  d := max - min;
  V := max;
  if (max <> 0) then S := d / max else S := 0;
  if S = 0 then begin
    H := 0;
  end
  else begin