sgraphutils.pas

AlphaControls是一个Delphi标准控件的集合

unit sGraphUtils;
{$I sDefs.inc}

interface

{ universal formula for blending // Peter
      Result := Div256((Src1 - Src2) * PercentOfSrc1 + Src2 * 256); 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,
  ComCtrls, sConst, ExtCtrls, Jpeg, sUtils, math;

// Paint tiled TGraphic on bitmap
procedure TileBitmap(Canvas: TCanvas; aRect: TRect; Graphic: TGraphic);

procedure AddRgn(var AOR : TAOR; Bmp : TBitmap; Width : integer);
procedure PaintItemBG(SkinIndex : integer; SkinSection : string; ci : TCacheInfo; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap);
procedure PaintItem(SkinIndex : integer; SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap); overload;
procedure PaintItem(SkinIndex : integer; SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; DC : HDC); overload;
procedure PaintControl(SkinIndex, BorderIndex : integer; SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; pP : TPoint; ItemBmp : TBitmap; Rgn : hrgn);
// Procedure needed for update.. Must be more universal | Serge
procedure PaintSimplySkinBorder(SkinIndex : integer; State : integer; Rect : TRect; DC : hdc);

procedure FillMaskedBorderH(Bmp, Mask : TBitmap; Mode : integer; Dst, Src : TRect; TransColor : TColor);
procedure FillMaskedBorderV(Bmp, Mask : TBitmap; Mode : integer; Dst, Src : TRect; TransColor : TColor);
procedure DrawMaskedRectangle(Bmp, Mask : TBitmap; Mode : integer; Dst : TPoint; Src : TRect; TransColor : TColor);
procedure DrawMaskRect(Bmp, Mask : TBitmap; Mode : integer; R : TRect; TransColor : TColor; Filling : boolean; ci : TCacheInfo);
procedure PaintSimplyBorder(Canvas : TCanvas; R : TRect; BGColor, ColorTop, ColorBottom : TColor; Lowered : boolean; Width : integer);

procedure DrawGlyphEx(Glyph, DstBmp : TBitmap; R : TRect; NumGlyphs : integer; Enabled, Grayed : boolean; DisabledGlyphKind : TsDisabledGlyphKind; State, Blend : integer);
//
function CreateDisBitmap(FOriginal: TBitmap; TransColor : TsRGB) : TBitmap;
procedure DisableBmp(SrcBmp: TBitmap);
procedure DisBmpColor(SrcBmp: TBitmap; Color : TColor);
// Converts bitmap to black-white palette (white = white, other = black)
procedure MonoBmp(SrcBmp: TBitmap);
// Converts bitmap to black-white palette
procedure BWBmp(SrcBmp: TBitmap; Delta : integer{0..384});
// Change color
//procedure ReplaceColor(SrcBmp: TBitmap; SrcColor, DstColor : TColor);
// Paints borders by template
procedure BorderByMask(SrcBmp, MskBmp: TBitmap; ColorTop, ColorBottom: TsColor);
// Fills rectangle on device context by Color
procedure FillDC(DC: hWnd; aRect: TRect; Color: TColor);
// Grayscale bitmap
procedure GrayScale(Bmp: TBitmap);
procedure GrayScaleTrans(Bmp: TBitmap; TransColor : TsColor);
// Draws stylish rectangle on DC by style @link(TsBorderStyle)
procedure BeveledBorder(DC: HDC; ColorTop, ColorBottom, Color: TColor; aRect: TRect; Width : integer; Bevel: TsBorderStyle; Soft : boolean);
// Draws stylish rounded rectangle on DC by style @link(TsBorderStyle)
//procedure BeveledRoundRect(DC: HDC; ColorTop, ColorBottom, Color: TColor; aRect: TRect; Width, Radius : integer; Bevel: TsBorderStyle);
procedure DrawLine(dc: HDC; Point1, Point2 : TPoint; LineColor: TColor);
procedure SharpenLine(DC: HDC; ColorLine: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
// Draws stylish line on DC by style @link(TsBorderStyle) from side @link(TsSide)
procedure BeveledLine(DC: HDC; ColorLine, Color: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
// Draws stylish line on DC by style @link(TsBorderStyle) from side @link(TsSide) without corner drawing
procedure ExBevLine(DC: HDC; ColorLine, Color: TColor; P1, P2: TPoint; Width : integer; Bevel: TsBorderStyle; Side: TsSide);
// Draws glyph for sCheckBox
procedure PaintCheck(Canvas: TCanvas; r: TRect; Enabled: boolean; Color: TColor);
// Function CutText get text with ellipsis if no enough place
function CutText(Canvas: TCanvas; Text: string; MaxLength : integer): string;
// Writes text on Canvas on custom rectangle by Flags
procedure WriteText(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TsRect; Flags: Longint);
procedure WriteTextEx(Canvas: TCanvas; Text: PChar; Enabled: boolean; var aRect : TsRect; Flags: Longint; SkinIndex : integer; Hot : boolean);
// Blending of two bitmaps, excluding pixels with color TransColor
//procedure SumBitmapsTrans(var SrcBmp, MskBmp: Graphics.TBitMap; Color, TransColor : TsColor);
// 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);
procedure SumBitmaps(SrcBmp, MskBmp: Graphics.TBitMap; Color : TsColor);
procedure SumBmpRect(DstBmp, SrcBmp: Graphics.TBitMap; Color : TsColor; SrcRect : TRect; DstPoint : TPoint);
procedure SumBitmapsEx(SrcBmp, MskBmp: Graphics.TBitMap; Piece : integer);
// Copy Bmp with AlphaMask
procedure CopyByMask(R1, R2 : TRect; Bmp1, Bmp2 : TBitmap; CI : TCacheInfo);
procedure PutMaskOnBmp(SrcBmp, MskBmp: Graphics.TBitMap; Left, Top : integer; Color : TsColor);
// Copying rectangle from SrcBmp to DstBmp, excluding pixels with color TransColor
procedure CopyTransRect(DstBmp, SrcBmp: Graphics.TBitMap; X, Y : integer; SrcRect: TRect; TransColor : TColor);
// 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);
// Creates bitmap like Bmp
function CreateBmpLike(Bmp: TBitmap): TBitmap;

// 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;
// Draws rectangle on device context
procedure DrawRectangleOnDC(DC: HDC; var R: TRect; ColorTop, ColorBottom: TColor; var Width: integer);
// Returns height of font
function GetFontHeight(hFont : HWnd): integer;
// Loads to Image TJpegImage or TBitmap from FileName
function LoadJpegOrBmp(Image: TPicture; FileName: string; Gray: boolean):boolean;
// Shows only controls, placed on form. Form is not visible
//procedure ShowOnlyControls(Form:TForm; ShowCaption,Value:boolean);
function CreateDisabledBitmapEx(FOriginal: TBitmap; OutlineColor, BackColor, HighlightColor, ShadowColor: TColor; DrawHighlight: Boolean): TBitmap;
procedure PaintLine(Canvas : TCanvas; p1, p2 : TPoint; Color : TColor);
procedure BlendLineLR(Bmp : TBitmap; Rect : TRect; Soft : boolean; Bevel : TsControlBevel);
procedure BlendLineTB(Bmp : TBitmap; Rect : TRect; Soft : boolean; Bevel : TsControlBevel);
procedure BlendLineRL(Bmp : TBitmap; Rect : TRect; Soft : boolean; Bevel : TsControlBevel);
procedure BlendLineBT(Bmp : TBitmap; Rect : TRect; Soft : boolean; Bevel : TsControlBevel);
procedure PaintBevel(Bmp: TBitmap; aRect: TRect; BevelWidth: integer; Bevel: TsControlBevel; Soft : boolean);
procedure FocusRect(Canvas : TCanvas; R : TRect);

implementation

uses sMaskData, sStyleSimply, sSkinProps, sGradient, sAlphaGraph, sBorders;

procedure AddRgn(var AOR : TAOR; Bmp : TBitmap; Width : integer);
var
  S : PRGBArray;
  X, Y, h, w, l, w2, cx: Integer;
  c, ct : TsColor;
  RegRect : TRect;
begin
  h := Bmp.Height div 2 - 1;
  w := Bmp.Width div 9 - 1;
  RegRect := Rect(-1, 0, 0, 0);
  ct.C := clFuchsia;
  l := Length(AOR);
  try
    for Y := 0 to h do begin
      S := Bmp.ScanLine[Y];
      for X := 0 to w do begin
        c.A := 0; c.R := S[X].R; c.G := S[X].G; c.B := S[X].B;
        if c.C = ct.C then begin
          if RegRect.Left <> -1 then begin
            RegRect.Right := RegRect.Right + 1;
          end
          else begin
            RegRect.Left := X;
            RegRect.Right := RegRect.Left + 1;
            RegRect.Top := Y;
            RegRect.Bottom := RegRect.Top + 1;
          end;
        end
        else begin
          if RegRect.Left <> -1 then begin
            SetLength(aOR, l + 1);
            AOR[l] := RegRect;
            inc(l);
            RegRect.Left := -1;
          end;
        end;
      end;
      if RegRect.Left <> -1 then begin
        SetLength(AOR, l + 1);
        AOR[l] := RegRect;
        inc(l);
        RegRect.Left := -1;
      end;
    end;

    w2 := Bmp.Width div 3 - 1;
    w := 2 * Bmp.Width div 9;
    cx := Width - Bmp.Width div 3;
    for Y := 0 to h do begin
      S := Bmp.ScanLine[Y];
      for X := w to w2 do begin
        c.A := 0; c.R := S[X].R; c.G := S[X].G; c.B := S[X].B;
        if c.C = ct.C then begin
          if RegRect.Left <> -1 then begin
            RegRect.Right := RegRect.Right + 1;
          end
          else begin
            RegRect.Left := cx + X;
            RegRect.Right := RegRect.Left + 1;
            RegRect.Top := Y;
            RegRect.Bottom := RegRect.Top + 1;
          end;
        end
        else begin
          if RegRect.Left <> -1 then begin
            SetLength(aOR, l + 1);
            AOR[l] := RegRect;
            inc(l);
            RegRect.Left := -1;
          end;
        end;
      end;
      if RegRect.Left <> -1 then begin
        SetLength(AOR, l + 1);
        AOR[l] := RegRect;
        inc(l);
        RegRect.Left := -1;
      end;
    end;
  except
  end;
end;

procedure PaintItemBG(SkinIndex : integer; SkinSection : string; ci : TCacheInfo; State : integer; R : TRect; pP : TPoint; ItemBmp : TBitmap);
var
  aRect: TRect;
  TransColor : TsColor;
  iDrawed : boolean;
  TempBmp : TBitmap;

  ImagePercent, GradientPercent : integer;
  PatternIndex, Transparency : integer;
  GradientData : string;
  GradientArray : TsGradArray;
  Color : TColor;
  Isjpg : boolean;

  procedure FillCanvas(bmp : TBitmap); begin
    BMP.Canvas.Pen.Style := psClear;
    BMP.Canvas.Brush.Style := bsSolid;
    BMP.Canvas.Brush.Color := Color;
    BMP.Canvas.Rectangle(aRect.Left, aRect.Top, aRect.Right + 1, aRect.Bottom + 1);
  end;
  procedure PaintAddons(var aBmp : TBitmap);
  var bmp : TBitmap;
  begin
    iDrawed := False;
    // BGImage painting
    if (ImagePercent > 0) then begin
      if IsJpg then begin
        if (PatternIndex > -1) and (PatternIndex < Length(pa)) then begin
          TileBitmap(aBmp.Canvas, aRect, pa[PatternIndex].Img);
          iDrawed := True;
        end;
      end
      else if (PatternIndex > -1) and (PatternIndex < Length(ma)) then begin
        TileBitmap(aBmp.Canvas, aRect, ma[PatternIndex].Bmp);
        iDrawed := True;
      end
      else begin
        FillCanvas(aBmp);
      end;
    end;
    // BGGradient painting
    if (GradientPercent > 0) then begin
      if iDrawed then begin
        bmp := TBitmap.Create;
        bmp.PixelFormat := pf24bit;
        bmp.Width := WidthOf(aRect);
        bmp.Height := HeightOf(aRect);
        try
          if Length(GradientData) > 0 then begin
            PaintGrad(Bmp, Rect(0, 0, Bmp.Width - 1, Bmp.Height - 1), GradientArray);
          end
          else begin
            FillCanvas(Bmp);
          end;

          TransColor.A := 0;
          TransColor.R := ImagePercent * 256 div 100;
          TransColor.G := TransColor.R;
          TransColor.B := TransColor.R;

          SumBmpRect(aBmp, Bmp, TransColor, Rect(0, 0, Bmp.Width - 1, Bmp.Height - 1), Point(aRect.Left, aRect.Top));
        finally
          FreeAndNil(Bmp);
        end;
      end
      else begin
        if Length(GradientData) > 0 then begin
          PaintGrad(aBmp, aRect, GradientArray);
        end
        else begin
          FillCanvas(aBmp);
        end;
      end;
    end;
    case GradientPercent + ImagePercent of
      1..99 : begin
        BlendColorRect(aBmp, aRect, (GradientPercent + ImagePercent),
                         Color);
      end;
      100 : begin end
      else begin
        FillCanvas(aBmp);
      end;
    end;
  end;
begin
  if not IsValidSkinIndex(SkinIndex) then Exit;
  aRect := R;
  IsJpg := False;
  // Properties definition from skin file
  case State of
    0 : begin
      Color := gd[SkinIndex].PaintingColor;
      ImagePercent := gd[SkinIndex].ImagePercent;
      GradientPercent := gd[SkinIndex].GradientPercent;
      PatternIndex := GetMaskIndex(SkinIndex, SkinSection, PatternFile);
      if not IsValidImgIndex(PatternIndex) then begin
        PatternIndex := GetPatternIndex(SkinIndex, SkinSection, PatternFile);
        IsJpg := PatternIndex > -1;
      end;
      GradientData := gd[SkinIndex].GradientData;
      GradientArray := gd[SkinIndex].GradientArray;
      Transparency := gd[SkinIndex].PaintingTransparency;
    end
    else begin
      Color := gd[SkinIndex].HotPaintingColor;
      ImagePercent := gd[SkinIndex].HotImagePercent;
      GradientPercent := gd[SkinIndex].HotGradientPercent;
      PatternIndex := GetMaskIndex(SkinIndex, SkinSection, HotPatternFile);
      if not IsValidImgIndex(PatternIndex) then begin
        PatternIndex := GetPatternIndex(SkinIndex, SkinSection, HotPatternFile);
        IsJpg := PatternIndex > -1;
      end;
      GradientData := gd[SkinIndex].HotGradientData;
      GradientArray := gd[SkinIndex].HotGradientArray;
      Transparency := gd[SkinIndex].HotPaintingTransparency;
    end;
  end;

  if ci.Ready and (Transparency = 100) then begin
    if ItemBmp <> ci.Bmp then begin
      BitBlt(ItemBmp.Canvas.Handle, aRect.Left, aRect.Top, WidthOf(aRect), HeightOf(aRect),
        ci.Bmp.Canvas.Handle, ci.X + pP.X, ci.Y + pP.Y, SRCCOPY);
    end;
  end
  else if not ci.Ready or (Transparency = 0) then begin
    PaintAddons(ItemBmp);
  end
  else if ci.Ready and (Transparency > 0) then begin
    TempBmp := TBitmap.Create;

    try
      TempBmp.Width := WidthOf(aRect);
      TempBmp.Height := HeightOf(aRect);
      TempBmp.PixelFormat := pf24bit;
      OffsetRect(aRect, - aRect.Left, - aRect.Top);
      PaintAddons(TempBmp);
      aRect := R;
      TransColor.A := 0;
      TransColor.R := Transparency * 255 div 100;
      TransColor.G := TransColor.R;
      TransColor.B := TransColor.R;

      if ci.Bmp <> ItemBmp then begin
        BitBlt(ItemBmp.Canvas.Handle, aRect.Left, aRect.Top, aRect.Right, aRect.Bottom,//ItemBmp.Width, ItemBmp.Height,
             ci.Bmp.Canvas.Handle, ci.X + pP.X, ci.Y + pP.y, SRCCOPY);
      end;
      SumBmpRect(ItemBmp, TempBmp, TransColor, Rect(0, 0, WidthOf(aRect), HeightOf(aRect)), Point(aRect.Left, aRect.Top));

    finally
      FreeAndNil(TempBmp);
    end;
  end;
end;

procedure PaintItem(SkinIndex : integer; SkinSection : string; ci : TCacheInfo; Filling : boolean; State : integer; R : TRect; pP : TPoint; DC : HDC); overload;
var
  TempBmp : TBitmap;
  SavedDC : HDC;
begin
  if not IsValidSkinIndex(SkinIndex) or (R.Left < 0) or (R.Top < 0) then Exit;
  SavedDC := SaveDC(DC);
  TempBmp := TBitmap.Create;
  try
    TempBmp.Width := WidthOf(r);
    TempBmp.Height := HeightOf(r);
    TempBmp.PixelFormat := pf24bit;

    PaintItem(SkinIndex, SkinSection, ci, Filling, State,
              Rect(0, 0, TempBmp.Width, TempBmp.Height), pP,
              TempBmp
    );
    BitBlt(DC, r.Left, r.top, WidthOf(r), HeightOf(r), TempBmp.Canvas.Handle, 0, 0, SRCCOPY);
  finally
    FreeAndNil(TempBmp);