procedure TCheckBox.CreateImage(var AImage: TCustomBitmap);
function DPIScaled(const ASize: Integer): Integer;
begin
Result := ASize * Round(Graphics.ScreenInfo.PixelsPerInchX / 96);
end;
const
BaseX = Integer(13);
BaseY = Integer(13);
var
LBitmap: TCustomBitmap;
LBackground: TColor;
LRect: TRect;
LX, LY: Integer;
begin
// setup background color
if Self.Color = clDefault then
LBackground := Self.GetDefaultColor(dctBrush)
else
LBackground := Self.Color;
// create image to paint on
LBitmap := Graphics.TCustomBitmap.Create{%H-};
try
// setup defaults
LBitmap.SetSize(Self.ClientWidth, Self.ClientHeight);
LBitmap.Canvas.AntialiasingMode := amDontCare; //amOn;
LBitmap.Canvas.CopyMode := cmSrcCopy;
// setup font
LBitmap.Canvas.Font := Self.Font;
if Self.Font.Color = clDefault then
LBitmap.Canvas.Font.Color := Self.GetDefaultColor(dctFont);
if (not Self.Enabled) then
LBitmap.Canvas.Font.Color := clGrayText;
// alpha test: transparency
// does not work :D (LBitmap is transparent but the control is not)
// currently it would let original CheckBox painting shine thru
if FTransparent then
begin
LBitmap.TransparentMode := tmFixed;
LBitmap.TransparentColor := LBackground;
LBitmap.Transparent := True;
end;
// setup initial canvas values
LBitmap.Canvas.Brush.Color := LBackground;
LBitmap.Canvas.Brush.Style := bsSolid;
LBitmap.Canvas.Pen.Style := psSolid;
// add small effect when the mouse is over the control
if FMouseOver then
LBitmap.Canvas.Pen.Color := clBtnHighlight
else
LBitmap.Canvas.Pen.Color := clBlack;
LBitmap.Canvas.Pen.Width := 1;
// clear image
LBitmap.Canvas.FillRect(LBitmap.Canvas.ClipRect);
// prepare circle coordinates
LX := DPIScaled(BaseX);
LY := DPIScaled(BaseY);
LRect.Top := (LBitmap.Canvas.Height - LY) div 2;
if (Self.Alignment = taRightJustify) and (Self.BiDiMode <> bdRightToLeft) then
LRect.Left := DPIScaled(1);
if (
((Self.Alignment = taRightJustify) and (Self.BiDiMode = bdRightToLeft))
or
((Self.Alignment = taLeftJustify) and (Self.BiDiMode = bdRightToLeft))
or
((Self.Alignment = taLeftJustify) and (Self.BiDiMode = bdLeftToRight))
)
then
LRect.Left := LBitmap.Canvas.ClipRect.Width - (LX);
LRect.Right := LRect.Left + LX;
LRect.Bottom := LRect.Top + LY;
InflateRect(LRect, -1, -1);
// choose color by current state
if Self.Checked or (Self.State = cbChecked) then
LBitmap.Canvas.Brush.Color := clLime;
if (not Self.Checked) or (Self.State = cbUnchecked) then
LBitmap.Canvas.Brush.Color := clRed;
if (Self.State = cbGrayed) then
LBitmap.Canvas.Brush.Color := clMedGray;
LBitmap.Canvas.Ellipse(LRect);
// prepare color and write text
LBitmap.Canvas.Brush.Color := LBackground;
if (Self.Alignment = taRightJustify) and (Self.BiDiMode <> bdRightToLeft) then
LBitmap.Canvas.TextOut(LX + DPIScaled(1), (LBitmap.Canvas.Height - LBitmap.Canvas.TextHeight(Self.Caption)) div 2, Self.Caption)
else
LBitmap.Canvas.TextOut(DPIScaled(1), (LBitmap.Canvas.Height - LBitmap.Canvas.TextHeight(Self.Caption)) div 2, Self.Caption);
// when focused draw a rectangle around
if Self.Focused then
begin
LBitmap.Canvas.Brush.Color := clActiveCaption;
LBitmap.Canvas.FrameRect(LBitmap.Canvas.ClipRect);
end;
// transport image
AImage := TCustomBitmap.Create;
AImage.Assign(LBitmap);
finally
LBitmap.Free;
end;
end;