sxbitmap32utils.pas

skin components for design of your applicastions

procedure Ellipse(Bitmap:TBitmap32;X,Y,W,H:Single);
const S_PI=3.141592;
var  T:Double;
     F:Boolean;
 R1,R2:Double;
     R:Double;
  Step:Single;
begin
 W:=W-1; H:=H-1;
 R1:=W/2; R2:=H/2;
 if R1>R2 then R:=R1 else R:=R2;
 if R<3 then Step:=0.7 else
  if R<6 then Step:=0.1 else
   if R<20 then Step:=0.05 else
    Step:=0.02;
 T:=0;
 F:=True;
 while T<2*S_PI do
  begin
   if F then
    begin
     F:=False;
     Bitmap.MoveToF(X+Cos(T)*R1+R1,Y+Sin(T)*R2+R2);
    end else
     Bitmap.LineToFS(X+Cos(T)*R1+R1,Y+Sin(T)*R2+R2);
   T:=T+Step;
  end;
 Bitmap.LineToFS(X+R1*2,Y+R2);
end;

procedure AdvDrawTo(Bitmap:TBitmap32;Dst:TBitmap32);
begin
 if Bitmap.Empty or Dst.Empty then exit;
 AdvBlockTransfer(Dst,0,0,Dst.BoundsRect,Bitmap,Bitmap.BoundsRect,Bitmap.DrawMode,
                  Bitmap.OnPixelCombine);
 Dst.Changed;
end;

procedure AdvDrawTo(Bitmap:TBitmap32;Dst:TBitmap32;DstX,DstY:Integer);
begin
 if Bitmap.Empty or Dst.Empty then exit;
 AdvBlockTransfer(Dst,DstX,DstY,Dst.BoundsRect,Bitmap,Bitmap.BoundsRect,
                  Bitmap.DrawMode,Bitmap.OnPixelCombine);
 Dst.Changed;
end;

procedure BlendBitmap(B:TBitmap32;A:Integer;C:TColor);
var X,Y:Integer;
     PP:PColor32;
     CC:TColor32;
begin
 PP:=@B.Bits[0];
 CC:=Color32(C);
 CC:=SetAlpha(CC,A);
 for X:=0 to B.Width-1 do
  for Y:=0 to B.Height-1 do
  begin
    BlendMem(CC,PP^);
    Inc(PP);
   end;
 EMMS;
end;

procedure SX_BlendLineEx(Src, Dst: PColor32; Count: Integer; M: TColor32);
var C:Cardinal;
begin
 while Count>0 do
  begin
   C:=Src^;
   C:=SetAlpha(C,MulDiv(AlphaComponent(C),M,255));
   SX_BlendMem(C,Dst^);
   Inc(Src);
   Inc(Dst);
   Dec(Count);
  end;
end;

procedure SX_CombineMem(F: TColor32; var B: TColor32; W: TColor32);
var  A1,R1,G1,B1:Cardinal;
     A2,R2,G2,B2:Cardinal;
 AA,AA2,RR,GG,BB:Cardinal;
begin
 A1:=(B and $FF000000) shr 24;
 R1:=(B and $00FF0000) shr 16;
 G1:=(B and $0000FF00) shr  8;
 B1:=(B and $000000FF);
 A2:=W;
 R2:=(F and $00FF0000) shr 16;
 G2:=(F and $0000FF00) shr  8;
 B2:=(F and $000000FF);
 AA:=A1+A2-Cardinal(MulDiv(A1,A2,255));
 AA2:=MulDiv(255-A2,A1,255);
 RR:=(R2*A2+AA2*R1) div (AA2+A2);
 GG:=(G2*A2+AA2*G1) div (AA2+A2);
 BB:=(B2*A2+AA2*B1) div (AA2+A2);
 B:=Color32(RR,GG,BB,AA);
end;

procedure SX_BlendMem(F: TColor32; var B: TColor32);
var  A1,R1,G1,B1:Cardinal;
     A2,R2,G2,B2:Cardinal;
 AA,AA2,RR,GG,BB:Cardinal;
begin
 A1:=(B and $FF000000) shr 24;
 R1:=(B and $00FF0000) shr 16;
 G1:=(B and $0000FF00) shr  8;
 B1:=(B and $000000FF);
 A2:=(F and $FF000000) shr 24;
 R2:=(F and $00FF0000) shr 16;
 G2:=(F and $0000FF00) shr  8;
 B2:=(F and $000000FF);
 AA:=A1+A2-Cardinal(MulDiv(A1,A2,255));
 AA2:=MulDiv(255-A2,A1,255);
 if A2+AA2=0 then
  begin
   RR:=0; GG:=0; BB:=0;
  end else
   begin
    RR:=(R2*A2+AA2*R1) div (AA2+A2);
    GG:=(G2*A2+AA2*G1) div (AA2+A2);
    BB:=(B2*A2+AA2*B1) div (AA2+A2);
   end;
 B:=Color32(RR,GG,BB,AA);
end;

procedure ColorToRedComponent(Dst,Src:TBitmap32);
var I:Integer;
  D,S:PColor32;
begin
 CheckParams(Dst,Src);
 Dst.SetSize(Src.Width,Src.Height);
 D:=@Dst.Bits[0];
 S:=@Src.Bits[0];
 for I:=0 to Src.Width*Src.Height-1 do
  begin
   D^:=Color32(Intensity(S^),0,0,AlphaComponent(S^));
   Inc(S); Inc(D);
  end;
 Dst.Changed;
end;

procedure ColorToGreenComponent(Dst, Src: TBitmap32);
var I:Integer;
  D,S:PColor32;
begin
 CheckParams(Dst,Src);
 Dst.SetSize(Src.Width,Src.Height);
 D:=@Dst.Bits[0];
 S:=@Src.Bits[0];
 for I:=0 to Src.Width*Src.Height-1 do
  begin
   D^:=Color32(0,Intensity(S^),0,AlphaComponent(S^));
   Inc(S); Inc(D);
  end;
 Dst.Changed;
end;

procedure ColorToBlueComponent(Dst,Src:TBitmap32);
var I:Integer;
  D,S:PColor32;
begin
 CheckParams(Dst,Src);
 Dst.SetSize(Src.Width,Src.Height);
 D:=@Dst.Bits[0];
 S:=@Src.Bits[0];
 for I:=0 to Src.Width*Src.Height-1 do
  begin
   D^:=Color32(0,0,Intensity(S^),AlphaComponent(S^));
   Inc(S); Inc(D);
  end;
 Dst.Changed;
end;

procedure AdvBlendBlock(Dst:TBitmap32;DstRect:TRect;Src:TBitmap32;SrcX,SrcY:Integer;
           CombineOp:TDrawMode;CombineCallBack:TPixelCombineEvent);
var SrcP,DstP:PColor32;
        SP,DP:PColor32;
     W,I,DstY:Integer;
begin
 W:=DstRect.Right-DstRect.Left;
 SrcP:=Src.PixelPtr[SrcX,SrcY];
 DstP:=Dst.PixelPtr[DstRect.Left,DstRect.Top];
 for DstY:=DstRect.Top to DstRect.Bottom-1 do
  begin
   case CombineOp of
    dmOpaque:MoveLongWord(SrcP^, DstP^, W);
    dmBlend:
        {if Src.MasterAlpha >= 255 then BlendLine(SrcP, DstP, W)
        else} SX_BlendLineEx(SrcP, DstP, W, Src.MasterAlpha);
    else //  dmCustom:
      begin
        SP := SrcP;
        DP := DstP;
        for I := 0 to W - 1 do
        begin
          CombineCallBack(SP^, DP^, Src.MasterAlpha);
          Inc(SP); Inc(DP);
        end;
      end;
   end;
   Inc(SrcP,Src.Width);
   Inc(DstP,Dst.Width);
  end;
end;

procedure AdvBlockTransfer(Dst:TBitmap32;DstX:Integer;DstY:Integer;DstClip:TRect;
           Src:TBitmap32;SrcRect:TRect;CombineOp:TDrawMode;CombineCallBack:TPixelCombineEvent);
var SrcX,SrcY:Integer;
begin
 if Src.Empty then exit;
 if (CombineOp=dmCustom) and not Assigned(CombineCallBack) then
  CombineOp:=dmOpaque;
 if (CombineOp=dmBlend) and (Src.MasterAlpha=0) then exit;
 SrcX:=SrcRect.Left;
 SrcY:=SrcRect.Top;
 IntersectRect(DstClip, DstClip, Dst.BoundsRect);
 IntersectRect(SrcRect, SrcRect, Src.BoundsRect);
 OffsetRect(SrcRect, DstX - SrcX, DstY - SrcY);
 IntersectRect(SrcRect, DstClip, SrcRect);
 DstClip := SrcRect;
 OffsetRect(SrcRect, SrcX - DstX, SrcY - DstY);
 if not IsRectEmpty(SrcRect) then
  try
   AdvBlendBlock(Dst,DstClip,Src,SrcRect.Left,SrcRect.Top,CombineOp,CombineCallBack);
  finally
   EMMS;
  end;
end;

procedure GetRenderedTextSize(Bitmap:TBitmap32;const Text:String;AALevel:Integer;var Width,Height:Integer);
var SZ:TSize;
begin
 Bitmap.Font.Size:=Bitmap.Font.Size shl AALevel;
 SZ:=Bitmap.TextExtent(Text);
 Width:=SZ.cx shr AALevel;
 Height:=SZ.cy shr AALevel;
 if Width shl AALevel<SZ.cx then
  Inc(Width);
 if Height shl AALevel<SZ.cy then
  Inc(Height);
 Bitmap.Font.Size:=Bitmap.Font.Size shr AALevel;
end;

procedure GetRenderedTextSize(Canvas:TCanvas;const Text:String;AALevel:Integer;var Width,Height:Integer);
var SZ:TSize;
begin
 Canvas.Font.Size:=Canvas.Font.Size shl AALevel;
 SZ:=Canvas.TextExtent(Text);
 Width:=SZ.cx shr AALevel;
 Height:=SZ.cy shr AALevel;
 if Width shl AALevel<SZ.cx then
  Inc(Width);
 if Height shl AALevel<SZ.cy then
  Inc(Height);
 Canvas.Font.Size:=Canvas.Font.Size shr AALevel;
end;

//Taken as private mothod of TBitmap32
procedure TextScaleDown(Bitmap:TBitmap32;const B,B2:TBitmap32;const N:Integer;const Color:TColor32);
var I, J, X, Y, P, Q, Sz, S: Integer;
    Src: PColor32;
    Dst: PColor32;
begin
  Sz := 1 shl N - 1;
  Dst := B.PixelPtr[0, 0];
  for J := 0 to B.Height - 1 do
  begin
    Y := J shl N;
    for I := 0 to B.Width - 1 do
    begin
      X := I shl N;
      S := 0;
      for Q := Y to Y + Sz do
      begin
        Src := B2.PixelPtr[X, Q];
        for P := X to X + Sz do
        begin
          S := S + Integer(Src^ and $000000FF);
          Inc(Src);
        end;
      end;
      S := S shr N shr N;
      Dst^ := TColor32(S shl 24) + Color;
      Inc(Dst);
    end;
  end;
end;

procedure DrawSmoothText(Bitmap:TBitmap32;const Text:String;var TextRect:TRect;
           Flags:UINT;AALevel:Integer;Color:TColor32);
var        R:TRect;
        B,B2:TBitmap32;
 StockBitmap:TBitmap;
 StockCanvas:TCanvas;
       Alpha:Integer;

 function ShrAALevelToMax(A:Integer):Integer;
 begin
  Result:=A shr AALevel;
  if Result shl AALevel<A then Inc(Result);
 end;

begin
 Alpha:=Color shr 24;
 Color:=Color and $00FFFFFF;
 AALevel:=Constrain(AALevel,1,4);
 R:=Rect(0,0,(TextRect.Right-TextRect.Left) shl AALevel,
             (TextRect.Bottom-TextRect.Top) shl AALevel);
 if Flags and DT_CALCRECT<>0 then
  begin
   Bitmap.Font.Size:=Bitmap.Font.Size shl AALevel;
   DrawText(Bitmap.Handle,PChar(Text),-1,R,Flags);
   TextRect.Right:=TextRect.Left+ShrAALevelToMax(R.Right);
   TextRect.Bottom:=TextRect.Top+ShrAALevelToMax(R.Bottom);
   Bitmap.Font.Size:=Bitmap.Font.Size shr AALevel;
   exit;
  end;
 B:=TBitmap32.Create;
 StockBitmap:=TBitmap.Create;
 try
  StockCanvas:=StockBitmap.Canvas;
  StockCanvas.Lock;
  try
   StockCanvas.Font:=Bitmap.Font;
   StockCanvas.Font.Size:=Bitmap.Font.Size shl AALevel;
   B2:=TBitmap32.Create;
   try
    B2.SetSize(R.Right,R.Bottom);
    B2.Clear(0);
    B2.Font:=StockCanvas.Font;
    B2.Font.Color:=clWhite;
    B2.Textout(R,Flags,Text);
    B.SetSize(ShrAALevelToMax(R.Right),ShrAALevelToMax(R.Bottom));
    TextScaleDown(Bitmap,B,B2,AALevel,Color);
   finally
    B2.Free;
   end;
  finally
   StockCanvas.Unlock;
  end;
  B.DrawMode:=dmBlend;
  B.MasterAlpha:=Alpha;
  B.CombineMode:=cmMerge;
  B.DrawTo(Bitmap,TextRect.Left,TextRect.Top);
 finally
  StockBitmap.Free;
  B.Free;
 end;
end;

//Taken from GR32
procedure TextBlueToAlpha(const B:TBitmap32;const Color:TColor32);
var I:Integer;
    P:PColor32;
    C:TColor32;
begin
 P:=@B.Bits[0];
 for I:=0 to B.Width*B.Height-1 do
  begin
   C:=P^;
   if C<>$00FFFFFF then
    begin
     C:=($FF-(P^ and $FF)) shl 24;
     C:=C or Color;
     P^:=C;
    end;
   Inc(P);
  end;
end;

procedure DrawAlphaText(Bitmap:TBitmap32;const Text:String;var TextRect:TRect;
           Flags:UINT;Color:TColor32);
var  B:TBitmap32;
     R:TRect;
 Alpha:TColor32;
begin
 if Bitmap.Empty then exit;
 Alpha:=Color shr 24;
 Color:=Color and $00FFFFFF;
 B:=TBitmap32.Create;
 try
  TextBlueToAlpha(B,Color);
  Bitmap.Textout(TextRect,Flags or DT_CALCRECT,Text);
  B.SetSize(TextRect.Right-TextRect.Left,TextRect.Bottom-TextRect.Top);
  B.Font:=Bitmap.Font;
  B.Clear($00FFFFFF);
  B.Font.Color:=clBlack;
  R:=TextRect;
  OffsetRect(R,-TextRect.Left,-TextRect.Top);
  B.Textout(R,Flags,Text);
  OffsetRect(R,TextRect.Left,TextRect.Top);
  TextRect:=R;
  TextBlueToAlpha(B,Color);
  B.DrawMode:=dmBlend;
  B.MasterAlpha:=Alpha;
  B.CombineMode:=cmMerge;
  B.DrawTo(Bitmap,TextRect.Left,TextRect.Top);
 finally
  B.Free;
 end;
end;

procedure DrawSmoothText(Canvas:TCanvas;const Text:String;var TextRect:TRect;
           Flags:UINT;AALevel:Integer);
var R:TRect;

 function ShrAALevelToMax(A:Integer):Integer;
 begin
  Result:=A shr AALevel;
  if Result shl AALevel<A then Inc(Result);
 end;

begin
 AALevel:=Constrain(AALevel,1,4);
 R:=Rect(0,0,(TextRect.Right-TextRect.Left) shl AALevel,
             (TextRect.Bottom-TextRect.Top) shl AALevel);
 if Flags and DT_CALCRECT<>0 then
  begin
   Canvas.Font.Size:=Canvas.Font.Size shl AALevel;
   DrawText(Canvas.Handle,PChar(Text),-1,R,Flags);
   TextRect.Right:=TextRect.Left+ShrAALevelToMax(R.Right);
   TextRect.Bottom:=TextRect.Top+ShrAALevelToMax(R.Bottom);
   Canvas.Font.Size:=Canvas.Font.Size shr AALevel;
  end;
end;


function IsInteger(A:Single):Boolean;
begin
 Result:=A+0.001-Floor(A)<0.01;
end;

procedure B32_Rectangle(B:TBitmap32;X1,Y1,X2,Y2:Single;Color:TColor32);
begin
 //B.FillRect
end;

end.