Rotate bitmap by real angle - delphi

Once upon a time, reading this question, I wondered how to rotate a bitmap by any degree without fiddling around with all the bits myself. Recently, someone else had obvious difficulties with it too.
There are already many questions dealing with rotation at 90° intervals, most notabaly this one, but I want to rotate by a real angle. Preferably with the possibility to adjust the image size due to the rotation, and with setting a custom (transparent) background color for the parts that will be added to image surface. I then suppose the signature of the routine would look something like:
procedure RotateBitmap(Bmp: TBitmap; Angle: Single; AdjustSize: Boolean;
BackColor: TColor);
These answers mention the following candidates for constructing this routine: SetWorldTransform, PlgBlt, GDI+, but I would like to see an (efficient) implementation.

tl;dr; Use GDI+
SetWorldTransform
With WinAPI's SetWorldTransform you can transform the space of device context: rotate, shear, offset, and scale. This is done by setting the members of a transform matrix of type XFORM. Fill its members according the documentation.
procedure RotateBitmap(Bmp: TBitmap; Rads: Single; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
C: Single;
S: Single;
XForm: tagXFORM;
Tmp: TBitmap;
begin
C := Cos(Rads);
S := Sin(Rads);
XForm.eM11 := C;
XForm.eM12 := S;
XForm.eM21 := -S;
XForm.eM22 := C;
Tmp := TBitmap.Create;
try
Tmp.TransparentColor := Bmp.TransparentColor;
Tmp.TransparentMode := Bmp.TransparentMode;
Tmp.Transparent := Bmp.Transparent;
Tmp.Canvas.Brush.Color := BkColor;
if AdjustSize then
begin
Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
XForm.eDx := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
XForm.eDy := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end
else
begin
Tmp.Width := Bmp.Width;
Tmp.Height := Bmp.Height;
XForm.eDx := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
XForm.eDy := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end;
SetGraphicsMode(Tmp.Canvas.Handle, GM_ADVANCED);
SetWorldTransform(Tmp.Canvas.Handle, XForm);
BitBlt(Tmp.Canvas.Handle, 0, 0, Tmp.Width, Tmp.Height, Bmp.Canvas.Handle,
0, 0, SRCCOPY);
Bmp.Assign(Tmp);
finally
Tmp.Free;
end;
end;
PlgBlt
The PlgBlt function performs a bit-block transfer from the specified rectangle in the source device context to the specified parallelogram in the destination device context. Map the corner points of the source image via the lpPoint parameter.
procedure RotateBitmap(Bmp: TBitmap; Rads: Single; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
C: Single;
S: Single;
Tmp: TBitmap;
OffsetX: Single;
OffsetY: Single;
Points: array[0..2] of TPoint;
begin
C := Cos(Rads);
S := Sin(Rads);
Tmp := TBitmap.Create;
try
Tmp.TransparentColor := Bmp.TransparentColor;
Tmp.TransparentMode := Bmp.TransparentMode;
Tmp.Transparent := Bmp.Transparent;
Tmp.Canvas.Brush.Color := BkColor;
if AdjustSize then
begin
Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
OffsetX := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
OffsetY := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end
else
begin
Tmp.Width := Bmp.Width;
Tmp.Height := Bmp.Height;
OffsetX := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
OffsetY := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end;
Points[0].X := Round(OffsetX);
Points[0].Y := Round(OffsetY);
Points[1].X := Round(OffsetX + Bmp.Width * C);
Points[1].Y := Round(OffsetY + Bmp.Width * S);
Points[2].X := Round(OffsetX - Bmp.Height * S);
Points[2].Y := Round(OffsetY + Bmp.Height * C);
PlgBlt(Tmp.Canvas.Handle, Points, Bmp.Canvas.Handle, 0, 0, Bmp.Width,
Bmp.Height, 0, 0, 0);
Bmp.Assign(Tmp);
finally
Tmp.Free;
end;
end;
Graphics32
Graphics32 is a library especially designed for fast bitmap handling. It requires some experience to grasp its full potential, but the documentation as well as the provided examples should get you started.
A rotation of a TBitmap32 image is done by transforming it by one of the many available transformation classes. The TAffineTransformation class is needed here. First, shift the image half its size to the upper left, then rotate, and shift the result back to the lower right, possibly using the new image dimensions.
uses
GR32, GR32_Transforms;
procedure RotateBitmap(Bmp: TBitmap32; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone; Transparent: Boolean = False); overload;
var
Tmp: TBitmap32;
Transformation: TAffineTransformation;
begin
Tmp := TBitmap32.Create;
Transformation := TAffineTransformation.Create;
try
Transformation.BeginUpdate;
Transformation.SrcRect := FloatRect(0, 0, Bmp.Width, Bmp.Height);
Transformation.Translate(-0.5 * Bmp.Width, -0.5 * Bmp.Height);
Transformation.Rotate(0, 0, -Degs);
if AdjustSize then
with Transformation.GetTransformedBounds do
Tmp.SetSize(Round(Right - Left), Round(Bottom - Top))
else
Tmp.SetSize(Bmp.Width, Bmp.Height);
Transformation.Translate(0.5 * Tmp.Width, 0.5 * Tmp.Height);
Transformation.EndUpdate;
Tmp.Clear(Color32(BkColor));
if not Transparent then
Bmp.DrawMode := dmTransparent;
Transform(Tmp, Bmp, Transformation);
Bmp.Assign(Tmp);
Bmp.OuterColor := Color32(BkColor);
if Transparent then
Bmp.DrawMode := dmTransparent;
finally
Transformation.Free;
Tmp.Free;
end;
end;
procedure RotateBitmap(Bmp: TBitmap; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone); overload;
var
Tmp: TBitmap32;
Transparent: Boolean;
begin
Tmp := TBitmap32.Create;
try
Transparent := Bmp.Transparent;
Tmp.Assign(Bmp);
RotateBitmapGR32(Tmp, Degs, AdjustSize, BkColor, Transparent);
Bmp.Assign(Tmp);
if Transparent then
Bmp.Transparent := True;
finally
Tmp.Free;
end;
end;
GDI+
Introduced in Windows XP, Microsoft's GDI+ API is more efficient then the default GDI API. For Delphi 2009 and up, the library is available from here. For older Delphi versions, the library is available from here.
In GDI+ the rotation is also done by a transformation matrix. Drawing works quite differently though. Create a TGPGraphics object and attach it to a device context with its constructor. Subsequently, drawing operations on the object are translated by the API and will be output to the destination context.
uses
GDIPOBJ, GDIPAPI; // < D2009
GdiPlus; // >= D2009
procedure RotateBitmap(Bmp: TBitmap; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
Tmp: TGPBitmap;
Matrix: TGPMatrix;
C: Single;
S: Single;
NewSize: TSize;
Graphs: TGPGraphics;
P: TGPPointF;
begin
Tmp := TGPBitmap.Create(Bmp.Handle, Bmp.Palette);
Matrix := TGPMatrix.Create;
try
Matrix.RotateAt(Degs, MakePoint(0.5 * Bmp.Width, 0.5 * Bmp.Height));
if AdjustSize then
begin
C := Cos(DegToRad(Degs));
S := Sin(DegToRad(Degs));
NewSize.cx := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
NewSize.cy := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
Bmp.Width := NewSize.cx;
Bmp.Height := NewSize.cy;
end;
Graphs := TGPGraphics.Create(Bmp.Canvas.Handle);
try
Graphs.Clear(ColorRefToARGB(ColorToRGB(BkColor)));
Graphs.SetTransform(Matrix);
Graphs.DrawImage(Tmp, (Cardinal(Bmp.Width) - Tmp.GetWidth) div 2,
(Cardinal(Bmp.Height) - Tmp.GetHeight) div 2);
finally
Graphs.Free;
end;
finally
Matrix.Free;
Tmp.Free;
end;
end;
Handling transparency
The routines above preserve the transparent settings of the fead bitmap, with the exception of the Graphics32 solution which requires an additional Transparent parameter.
Performance and image quality
I wrote a test application (see full code below) to tune the performance of the various methods and to compare the resulting image quality.
The first and most important conclusion is that GDI+ uses anti-aliasing where the others do not, resulting in the best image quality. (I unsuccessfully tried to prevent anti-aliasing by setting CompositingQuality, InterpolationMode, SmoothingMode, and PixelOffsetMode, so when anti-aliasing is not preferred, do not use GDI+.)
Furthermore, the GDI+ solution is also the fastest method, by far.
unit RotateTestForm;
interface
uses
Windows, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, ExtCtrls,
JPEG, Math, GR32, GR32_Transforms, GDIPOBJ, GDIPAPI {, GdiPlus};
type
TTestForm = class(TForm)
private
FImage: TImage;
FOpenDialog: TOpenDialog;
procedure FormPaint(Sender: TObject);
public
constructor Create(AOwner: TComponent); override;
end;
var
TestForm: TTestForm;
implementation
{$R *.dfm}
procedure RotateBitmapSWT(Bmp: TBitmap; Rads: Single; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
C: Single;
S: Single;
XForm: TXForm;
Tmp: TBitmap;
begin
C := Cos(Rads);
S := Sin(Rads);
XForm.eM11 := C;
XForm.eM12 := S;
XForm.eM21 := -S;
XForm.eM22 := C;
Tmp := TBitmap.Create;
try
Tmp.TransparentColor := Bmp.TransparentColor;
Tmp.TransparentMode := Bmp.TransparentMode;
Tmp.Transparent := Bmp.Transparent;
Tmp.Canvas.Brush.Color := BkColor;
if AdjustSize then
begin
Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
XForm.eDx := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
XForm.eDy := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end
else
begin
Tmp.Width := Bmp.Width;
Tmp.Height := Bmp.Height;
XForm.eDx := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
XForm.eDy := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end;
SetGraphicsMode(Tmp.Canvas.Handle, GM_ADVANCED);
SetWorldTransform(Tmp.Canvas.Handle, XForm);
BitBlt(Tmp.Canvas.Handle, 0, 0, Tmp.Width, Tmp.Height, Bmp.Canvas.Handle,
0, 0, SRCCOPY);
Bmp.Assign(Tmp);
finally
Tmp.Free;
end;
end;
procedure RotateBitmapPLG(Bmp: TBitmap; Rads: Single; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
C: Single;
S: Single;
Tmp: TBitmap;
OffsetX: Single;
OffsetY: Single;
Points: array[0..2] of TPoint;
begin
C := Cos(Rads);
S := Sin(Rads);
Tmp := TBitmap.Create;
try
Tmp.TransparentColor := Bmp.TransparentColor;
Tmp.TransparentMode := Bmp.TransparentMode;
Tmp.Transparent := Bmp.Transparent;
Tmp.Canvas.Brush.Color := BkColor;
if AdjustSize then
begin
Tmp.Width := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
Tmp.Height := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
OffsetX := (Tmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
OffsetY := (Tmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end
else
begin
Tmp.Width := Bmp.Width;
Tmp.Height := Bmp.Height;
OffsetX := (Bmp.Width - Bmp.Width * C + Bmp.Height * S) / 2;
OffsetY := (Bmp.Height - Bmp.Width * S - Bmp.Height * C) / 2;
end;
Points[0].X := Round(OffsetX);
Points[0].Y := Round(OffsetY);
Points[1].X := Round(OffsetX + Bmp.Width * C);
Points[1].Y := Round(OffsetY + Bmp.Width * S);
Points[2].X := Round(OffsetX - Bmp.Height * S);
Points[2].Y := Round(OffsetY + Bmp.Height * C);
PlgBlt(Tmp.Canvas.Handle, Points, Bmp.Canvas.Handle, 0, 0, Bmp.Width,
Bmp.Height, 0, 0, 0);
Bmp.Assign(Tmp);
finally
Tmp.Free;
end;
end;
procedure RotateBitmapGR32(Bmp: TBitmap32; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone; Transparent: Boolean = False); overload;
var
Tmp: TBitmap32;
Transformation: TAffineTransformation;
begin
Tmp := TBitmap32.Create;
Transformation := TAffineTransformation.Create;
try
Transformation.BeginUpdate;
Transformation.SrcRect := FloatRect(0, 0, Bmp.Width, Bmp.Height);
Transformation.Translate(-0.5 * Bmp.Width, -0.5 * Bmp.Height);
Transformation.Rotate(0, 0, -Degs);
if AdjustSize then
with Transformation.GetTransformedBounds do
Tmp.SetSize(Round(Right - Left), Round(Bottom - Top))
else
Tmp.SetSize(Bmp.Width, Bmp.Height);
Transformation.Translate(0.5 * Tmp.Width, 0.5 * Tmp.Height);
Transformation.EndUpdate;
Tmp.Clear(Color32(BkColor));
if not Transparent then
Bmp.DrawMode := dmTransparent;
Transform(Tmp, Bmp, Transformation);
Bmp.Assign(Tmp);
Bmp.OuterColor := Color32(BkColor);
if Transparent then
Bmp.DrawMode := dmTransparent;
finally
Transformation.Free;
Tmp.Free;
end;
end;
procedure RotateBitmapGR32(Bmp: TBitmap; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone); overload;
var
Tmp: TBitmap32;
Transparent: Boolean;
begin
Tmp := TBitmap32.Create;
try
Transparent := Bmp.Transparent;
Tmp.Assign(Bmp);
RotateBitmapGR32(Tmp, Degs, AdjustSize, BkColor, Transparent);
Bmp.Assign(Tmp);
if Transparent then
Bmp.Transparent := True;
finally
Tmp.Free;
end;
end;
procedure RotateBitmapGDIP(Bmp: TBitmap; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
Tmp: TGPBitmap;
Matrix: TGPMatrix;
C: Single;
S: Single;
NewSize: TSize;
Graphs: TGPGraphics;
P: TGPPointF;
begin
Tmp := TGPBitmap.Create(Bmp.Handle, Bmp.Palette);
Matrix := TGPMatrix.Create;
try
Matrix.RotateAt(Degs, MakePoint(0.5 * Bmp.Width, 0.5 * Bmp.Height));
if AdjustSize then
begin
C := Cos(DegToRad(Degs));
S := Sin(DegToRad(Degs));
NewSize.cx := Round(Bmp.Width * Abs(C) + Bmp.Height * Abs(S));
NewSize.cy := Round(Bmp.Width * Abs(S) + Bmp.Height * Abs(C));
Bmp.Width := NewSize.cx;
Bmp.Height := NewSize.cy;
end;
Graphs := TGPGraphics.Create(Bmp.Canvas.Handle);
try
Graphs.Clear(ColorRefToARGB(ColorToRGB(BkColor)));
Graphs.SetTransform(Matrix);
Graphs.DrawImage(Tmp, (Cardinal(Bmp.Width) - Tmp.GetWidth) div 2,
(Cardinal(Bmp.Height) - Tmp.GetHeight) div 2);
finally
Graphs.Free;
end;
finally
Matrix.Free;
Tmp.Free;
end;
end;
{ TTestForm }
constructor TTestForm.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
Font.Name := 'Tahoma';
Top := 0;
ClientWidth := 560;
ClientHeight := 915;
Show;
FImage := TImage.Create(Self);
FOpenDialog := TOpenDialog.Create(Self);
FOpenDialog.Title := 'Select an small sized image (min. 100 x 100)';
FOpenDialog.Options := FOpenDialog.Options + [ofFileMustExist];
FOpenDialog.Filter := 'JPEG|*.JPG|BMP|*.BMP';
if FOpenDialog.Execute then
begin
FImage.Picture.LoadFromFile(FOpenDialog.FileName);
OnPaint := FormPaint;
Invalidate;
end
else
Application.Terminate;
end;
procedure TTestForm.FormPaint(Sender: TObject);
var
Img: TBitmap;
Bmp: TBitmap;
Bmp32: TBitmap32;
BkColor: TColor;
AdjustSize: Boolean;
Degs: Integer;
Rads: Single;
RotCount: Integer;
I: Integer;
Tick: Cardinal;
begin
Img := TBitmap.Create;
Bmp := TBitmap.Create;
Bmp32 := TBitmap32.Create;
try
BkColor := clBtnFace;
Img.Canvas.Brush.Color := BkColor;
Img.Width := 100;
Img.Height := 100;
Img.Canvas.Draw(0, 0, FImage.Picture.Graphic);
AdjustSize := False;
Degs := 45;
Rads := DegToRad(Degs);
RotCount := 1000;
Canvas.TextOut(10, 10, 'Original:');
Canvas.Draw(10, 30, Img);
Canvas.TextOut(10, 140, Format('Size = %d x %d', [Img.Width, Img.Height]));
Canvas.TextOut(10, 160, Format('Angle = %d°', [Degs]));
Canvas.TextOut(10, 250, Format('%d rotations:', [RotCount]));
Canvas.TextOut(120, 10, 'SetWorldTransform:');
Bmp.Assign(Img);
RotateBitmapSWT(Bmp, Rads, AdjustSize, BkColor);
Canvas.Draw(120, 30, Bmp);
if not AdjustSize then
begin
Tick := GetTickCount;
for I := 0 to RotCount - 2 do
RotateBitmapSWT(Bmp, Rads, AdjustSize, BkColor);
Canvas.TextOut(120, 250, Format('%d msec', [GetTickCount - Tick]));
Canvas.Draw(120, 140, Bmp);
end;
Canvas.TextOut(230, 10, 'PlgBlt:');
Bmp.Assign(Img);
RotateBitmapPLG(Bmp, Rads, AdjustSize, BkColor);
Canvas.Draw(230, 30, Bmp);
if not AdjustSize then
begin
Tick := GetTickCount;
for I := 0 to RotCount - 2 do
RotateBitmapPLG(Bmp, Rads, AdjustSize, BkColor);
Canvas.TextOut(230, 250, Format('%d msec', [GetTickCount - Tick]));
Canvas.Draw(230, 140, Bmp);
end;
Canvas.TextOut(340, 10, 'Graphics32:');
Bmp.Assign(Img);
RotateBitmapGR32(Bmp, Degs, AdjustSize, BkColor);
Canvas.Draw(340, 30, Bmp);
if not AdjustSize then
begin
Tick := GetTickCount;
for I := 0 to RotCount - 2 do
RotateBitmapGR32(Bmp, Degs, AdjustSize, BkColor);
Canvas.TextOut(340, 250, Format('%d msec', [GetTickCount - Tick]));
Canvas.Draw(340, 140, Bmp);
// Without in between conversion to TBitmap:
Bmp32.Assign(Img);
Tick := GetTickCount;
for I := 0 to RotCount - 1 do
RotateBitmapGR32(Bmp32, Degs, AdjustSize, BkColor, False);
Canvas.TextOut(340, 270, Format('%d msec (optimized)',
[GetTickCount - Tick]));
end;
Canvas.TextOut(450, 10, 'GDI+ :');
Bmp.Assign(Img);
RotateBitmapGDIP(Bmp, Degs, AdjustSize, BkColor);
Canvas.Draw(450, 30, Bmp);
if not AdjustSize then
begin
Tick := GetTickCount;
for I := 0 to RotCount - 2 do
RotateBitmapGDIP(Bmp, Degs, AdjustSize, BkColor);
Canvas.TextOut(450, 250, Format('%d msec', [GetTickCount - Tick]));
Canvas.Draw(450, 140, Bmp);
end;
finally
Bmp32.Free;
Bmp.Free;
Img.Free;
OnPaint := nil;
end;
end;
end.

If someone is looking into image rotation, they might also take a look at the Mitov video library (free for non-commercial use: link). VCL and FireMonkey. It takes care of all the low-level details, which lets us avoid the kind of detailed coding that NGLN's excellent answer explores.
We've been using it for the past two years and have been very happy with it in our commercial app.
It has a rotate component that works with static images and video streams. Their library is fully-multi-tasking, optionally using all the cores and low level primitives available, on Intel chipsets with Intel's own performance library (http://software.intel.com/en-us/articles/intel-ipp)
On moderate hardware we can run multiple video or bmp streams which we rotate, clip, scale, and process at the pixel level, in real-time.

Related

Draw on TeeChart directly with GDI+

How to rotate and draw a transperent PNG image using GDI+ directly on TChart?
Currently I load PNG image to a bitmap and use two bitmaps for GDI+ rotation (it works very fast) and then make the target bitmap transparent and draw it on TChart's canvas (it works slow when transparency is on).
procedure TPitchDisplay._chartAfterDraw(Sender: TObject);
var
c: TCanvas3D;
pw, ph: Integer;
r: TRect;
bmp: TBitmap;
rotAngle: Integer;
begin
_setKnobBounds();
c := _chart.Canvas;
_drawCircle(c, _knob.CenterPoint.X, _knob.CenterPoint.Y, Round(_knob.YRadius * 0.9));
c.StretchDrawQuality := sqHigh;
pw := 450;
ph := Round((pw / _shipBitmap.Width) * _shipBitmap.Height);
r.Left := _chart.ChartXCenter - pw div 2;
r.Top := Round(_chart.Height / 3);
r.Width := pw;
r.Height := ph;
//Draw water
c.StretchDraw(Rect(0, r.Top + Round(ph / 1.5), _chart.Width, _chart.Height), _waterBitmap);
//Draw rotated ship over it
bmp := TBitmap.Create();
try
bmp.Width := Round(_shipBitmap.Width * 1.2);
bmp.Height := Round(_shipBitmap.Height * 1.7);
bmp.TransparentColor := clBlack;
bmp.Transparent := True;
bmp.TransparentMode := TTransparentMode.tmFixed;
if VarIsNumeric(_pitchBox.Value) then
rotAngle := _pitchBox.Value
else
rotAngle := 0;
TGraphUtils.RotateBitmap(_shipBitmap, bmp, 0.5, 0.7, rotAngle, False, clBlack);
c.StretchDraw(r, bmp);
finally
bmp.Free();
end;
end;
Rotation routine:
class procedure TGraphUtils.RotateBitmap(srcBmp, tgtBmp: TBitmap; rotateAtX, rotateAtY: Single; Degs: Integer; AdjustSize: Boolean;
BkColor: TColor = clNone);
var
Tmp: TGPBitmap;
Matrix: TGPMatrix;
C: Single;
S: Single;
NewSize: TSize;
Graphs: TGPGraphics;
P: TGPPointF;
attr: TGPImageAttributes;
begin
Tmp := TGPBitmap.Create(srcBmp.Handle, srcBmp.Palette);
Matrix := TGPMatrix.Create();
try
Matrix.RotateAt(Degs, MakePoint(rotateAtX * srcBmp.Width, rotateAtY * srcBmp.Height));
if AdjustSize then begin
C := Cos(DegToRad(Degs));
S := Sin(DegToRad(Degs));
NewSize.cx := Round(srcBmp.Width * Abs(C) + srcBmp.Height * Abs(S));
NewSize.cy := Round(srcBmp.Width * Abs(S) + srcBmp.Height * Abs(C));
tgtBmp.Width := NewSize.cx;
tgtBmp.Height := NewSize.cy;
end;
Graphs := TGPGraphics.Create(tgtBmp.Canvas.Handle);
attr := TGPImageAttributes.Create;
try
Graphs.Clear(ColorRefToARGB(ColorToRGB(BkColor)));
Graphs.SetTransform(Matrix);
//attr.SetColorKey($FFFFFF {TGPColor.Blue}, $FFFFFF {TGPColor.Blue}, ColorAdjustTypeBitmap);
Graphs.DrawImage(Tmp, (Cardinal(tgtBmp.Width) - Tmp.GetWidth) div 2,
(Cardinal(tgtBmp.Height) - Tmp.GetHeight) div 2);
finally
attr.Free();
Graphs.Free();
end;
finally
Matrix.Free();
Tmp.Free();
end;
end;
procedure TForm1.Chart1AfterDraw(Sender: TObject);
var
GPImage: TGPImage;
GPGraphics: TGPGraphics;
Matrix: TGPMatrix;
c: TCanvas3d;
begin
c := Chart1.Canvas;
GPImage := TGPImage.Create('e:\2.png');
GPGraphics := TGPGraphics.Create(C.Handle);
Matrix := TGPMatrix.Create;
Matrix.Rotate(30);
Matrix.Scale(0.5, 0.5);
GPGraphics.SetTransform(Matrix);
GPGraphics.DrawImage(GPImage, 150, 0);
Matrix.Free;
GPGraphics.Free;
GPimage.Free;
end;
Not precise example of output into form center:
IM := TGPMatrix.Create;
IM := Matrix.Clone;
IM.Invert;
pc := MakePoint(Width div 2 - GPImage.GetWidth() div 2,
Height div 2 - Integer(GPImage.GetHeight) div 2);
Im.TransformPoints(pgppoINT(#pc));
GPGraphics.DrawImage(GPImage, pc);

Changing the bsBDiagonal line width and gaps

I am trying to produce a consistent interface in high DPI and standard DPI environments. We have a selection box that with paint using something like this:
theCanvas.Brush.style := bsBDiagonal;
theCanvas.pen.style := psClear;
theCanvas.brush.color := clBlue;
Is there any way to change the width of the lines and the gaps between the lines that are drawn by bsBDiagonal because these don't take into account the DPI of the monitor. A user with a high DPI system will see very fine diagonal lines that are very close together whereas a person with a regular DPI monitor will see painting that is further apart and wider.
For example. The one on the left is what a user on a regular DPI monitor will see and the one on the right is the high DPI equivalent.
Hatch brush always works in graphic device units. I met this problem with printers in old times and made this procedure:
//Fillstep depends linearly on DPI
procedure PrintHatchPolygon(Canvas: TCanvas; Pts: array of TPoint;
FillStep: Integer);
var
ClipRgn: HRGN;
r: TRect;
i, MaxSize, OldPenColor, HatchStyle: Integer;
procedure Line(X1, Y1, X2, Y2: Integer);
begin
Canvas.MoveTo(X1, Y1);
Canvas.LineTo(X2, Y2);
end;
begin
case Canvas.Brush.Style of
bsVertical:
HatchStyle := 1;
bsHorizontal:
HatchStyle := 2;
bsFDiagonal:
HatchStyle := 4;
bsBDiagonal:
HatchStyle := 8;
bsCross:
HatchStyle := 3;
bsDiagCross:
HatchStyle := 12;
else
HatchStyle := 0;
end;
OldPenColor := Canvas.Pen.Color;
Canvas.Pen.Color := Canvas.Brush.Color;
ClipRgn := CreatePolygonRgn(Pts, High(Pts) + 1, ALTERNATE);
GetRgnBox(ClipRgn, r);
MaxSize := r.Bottom - r.Top;
if MaxSize < (r.Right - r.Left) then
MaxSize := r.Right - r.Left;
SelectClipRgn(Canvas.Handle, ClipRgn);
with r do begin
if (HatchStyle and 1) > 0 then
for i := 1 to (r.Right - r.Left) div FillStep do
Line(Left + i * FillStep, Top, Left + i * FillStep, Bottom);
if (HatchStyle and 2) > 0 then
for i := 1 to (r.Bottom - r.Top) div FillStep do
Line(Left, Top + i * FillStep, Right, Top + i * FillStep);
//to equalize step
//FillStep := 1414 * FillStep div 1000;
if (HatchStyle and 4) > 0 then
for i := 1 to 2 * MaxSize div FillStep do
Line(Left, Bottom - i * FillStep, Left + i * FillStep, Bottom);
if (HatchStyle and 8) > 0 then
for i := 1 to 2 * MaxSize div FillStep do
Line(Left, Top + i * FillStep, Left + i * FillStep, Top);
end;
SelectClipRgn(Canvas.Handle, 0);
DeleteObject(ClipRgn);
Canvas.Pen.Color := OldPenColor;
end;
procedure TForm1.Button7Click(Sender: TObject);
var
P: array [0 .. 2] of TPoint;
begin
P[0] := Point(10, 10);
P[1] := Point(100, 10);
P[2] := Point(10, 200);
Canvas.Brush.Style := bsDiagCross;
Canvas.Brush.Color := clRed;
//value 8 for usual monitor dpi (72?)
//value 60 for 600dpi printer
PrintHatchPolygon(Canvas, P, 8);
Canvas.Brush.Style := bsClear;
Canvas.Polygon(P);
end;
Another alternative is to use a custom brush. I couldn't get the custom brush option working with transparency.
procedure SetupHatchBitmapBrush(ABitmap: TBitmap; const ABrushStyle:
TBrushStyle; const AFillStep: Integer; const APenColor: TColor);
var
bitmapSize: TSize;
rect: TRect;
cntr: Integer;
maxSize: Integer;
oldPenColor: Integer;
hatchStyle: Integer;
procedure Line(bBitmap: TBitmap; bX1, bY1, bX2, bY2: Integer);
begin
bBitmap.Canvas.MoveTo(bX1, bY1);
bBitmap.Canvas.LineTo(bX2, bY2);
end;
begin
case ABrushStyle of
bsVertical: hatchStyle := 1;
bsHorizontal: hatchStyle := 2;
bsFDiagonal: hatchStyle := 4;
bsBDiagonal: hatchStyle := 8;
bsCross: hatchStyle := 3;
bsDiagCross: hatchStyle := 12;
else
hatchStyle := 0;
end;
oldPenColor := ABitmap.Canvas.Pen.Color;
try
ABitmap.Canvas.Pen.Color := APenColor;
maxSize := ABitmap.Height;
if maxSize < ABitmap.Width then
maxSize := ABitmap.Width;
if (hatchStyle and 1) > 0 then
for cntr := 1 to ABitmap.Width div AFillStep do
Line(ABitmap, cntr * AFillStep, 0, cntr * AFillStep, ABitmap.Height);
if (hatchStyle and 2) > 0 then
for cntr := 1 to ABitmap.Height div AFillStep do
Line(ABitmap, 0, cntr * AFillStep, ABitmap.Width, cntr * AFillStep);
if (hatchStyle and 4) > 0 then
for cntr := 1 to 2 * maxSize div AFillStep do
Line(ABitmap, 0, ABitmap.Height - cntr * AFillStep, cntr * AFillStep, ABitmap.Height);
if (hatchStyle and 8) > 0 then
for cntr := 1 to 2 * maxSize div AFillStep do
Line(ABitmap, 0, cntr * AFillStep, cntr * AFillStep, 0);
finally
ABitmap.Canvas.Pen.Color := oldPenColor;
end;
end;
function CreatePatternBitmap(const ABrushStyle: TBrushStyle; const APenColor,
ABackgroundColor: TColor; const AScaleFactor: Double): TBitmap;
const
DEFAULT_SIZE = 8;
var
bitmapStep: Integer;
begin
bitmapStep := Trunc(DEFAULT_SIZE * AScaleFactor);
Result := TBitmap.Create;
Result.Canvas.Brush.Color := clWhite;
Result.Canvas.Brush.Style := bsSolid;
Result.PixelFormat := pf32bit;
Result.SetSize(bitmapStep * 2, bitmapStep * 2);
SetupHatchBitmapBrush(Result, ABrushStyle, bitmapStep, APenColor);
end;
At some point we need to create the bitmap.
begin
FBitmap := CreatePatternBitmap(bsBDiagonal, clRed, clWhite, 1.5);
end;
Painting would look like this:
begin
Canvas.Brush.Color := clBlue;
Canvas.Pen.Style := psClear;
Canvas.Brush.style := bsBDiagonal;
Canvas.Brush.Bitmap := FBitmap;
Canvas.Rectangle(Rect(10, 10, 100, 100));
end;

How can I replace color on TCanvas on Delphi?

How can I replace color on TCanvas on Delphi XE2? The following code works incredibly slow:
for y := ARect.Top to ARect.Top + ARect.Height - 1 do
for x := ARect.Left to ARect.Left + ARect.Width - 1 do
if Canvas.Pixels[x, y] = FixedColor then
Canvas.Pixels[x, y] := Canvas.Pixels[ARect.Left, ARect.Top];
Here are two function (with and without tolerance) to replace the color:
Bonus:
Code to test the functions also provided. Load your image in a TImage control, then use the MouseUp event to change the color under mouse.
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = R)
AND (aPixel^.rgbtGreen = G)
AND (aPixel^.rgbtBlue = B) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure ReplaceColor(BMP: TBitmap; OldColor, NewColor: TColor; ToleranceR, ToleranceG, ToleranceB: Byte);
VAR
x, y: Integer;
R,G,B: Byte;
R_,G_,B_: Byte;
aPixel: PRGBTriple;
begin
R:= GetRValue(OldColor);
G:= GetGValue(OldColor);
B:= GetBValue(OldColor);
R_:= GetRValue(NewColor);
G_:= GetGValue(NewColor);
B_:= GetBValue(NewColor);
BMP.PixelFormat := pf24bit;
for y := 0 to BMP.Height - 1 do
for x := 0 to BMP.Width - 1 do
begin
aPixel := BMP.ScanLine[y];
Inc(aPixel, x);
if (abs(aPixel^.rgbtRed - R)< ToleranceR)
AND (abs(aPixel^.rgbtGreen- G)< ToleranceG)
AND (abs(aPixel^.rgbtBlue - B)< ToleranceB) then
begin
aPixel^.rgbtRed := R_;
aPixel^.rgbtGreen := G_;
aPixel^.rgbtBlue := B_;
end;
end;
end;
procedure TfrmTester.imgOnMouseUp(Sender: TObject; Shift: TShiftState; X, Y: Integer);
VAR
PixelClr: TColor;
BMP: TBitmap;
begin
// Collect the new color, under mouse pointer
PixelClr:= imgReplaceOrig.Picture.Bitmap.Canvas.Pixels[x, y];
if PixelClr< 0 then EXIT;
Label1.Caption := 'x'+IntToStr(X)+':y='
+ IntToStr(Y)
+' r'+ IntToStr(GetRValue(Pixel))
+', g'+ IntToStr(GetGValue(Pixel))
+', b'+ IntToStr(GetBValue(Pixel));
BMP:= TBitmap.Create;
BMP.Assign(imgReplaceOrig.Picture.Bitmap);
// Replace the color
cGraphUtil.ReplaceColor(BMP, PixelClr, clBlue, 44, 44, 44);
imgReplace.Picture.Assign(BMP);
FreeAndNil(BMP);
end;
var
aBitmap: TBitmap;
x, y: Integer;
aPixel: PRGBTriple;
...
aBitmap := TBitmap.Create;
try
aBitmap.PixelFormat := pf24bit;
aBitmap.Height := ARect.Height;
aBitmap.Width := ARect.Width;
aBitmap.Canvas.CopyRect(TRect.Create(0, 0, aBitmap.Width, aBitmap.Height), Canvas, ARect);
for y := 0 to aBitmap.Height - 1 do
for x := 0 to aBitmap.Width - 1 do
begin
aPixel := aBitmap.ScanLine[y];
Inc(aPixel, x);
if (aPixel^.rgbtRed = GetRValue(FixedColor)) and (aPixel^.rgbtGreen = GetGValue(FixedColor)) and (aPixel^.rgbtBlue = GetBValue(FixedColor)) then
aPixel^ := PRGBTriple(aBitmap.ScanLine[y])^;
end;
Canvas.Draw(ARect.Left, ARect.Top, aBitmap);
finally
aBitmap.Free;
end;

Alphablend and TransparentBlt

This question is related to my earlier question on SO.
I want to combine two layers with alpha applied only to a specific portion of the source layer. One way I tried was to set SourceConstantAlpha to $ff (and have the function use the alpha channel in the source layer).
This kind of works - although slow (I guess I can speed it up by using ScanLines), the kind of part is that I cannot figure out what to set the alpha channel to. The documentation suggests that the calculation is:
st.Red = Src.Red + (1 - Src.Alpha) * Dst.Red
I have tried a few different values by guess work, but my first question is: How do I compute the alpha value?
After reading a few other SO questions, I came across the TransparentBlt function, which does the masking well (and fast) but not the transparency, is there a way to combine
these two calls together (maybe using a third layer) ?
unit MainWnd;
interface
uses
Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
Dialogs, ExtCtrls, ControlsEx;
type
{------------------------------------------------------------------------------}
TfrmMain = class(TForm)
PaintBox1: TPaintBox;
procedure PaintBox1Paint(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
var
frmMain: TfrmMain;
implementation
{$R *.dfm}
{..............................................................................}
procedure copyToAlpha(const in_bitmap : TBitmap; const in_transparentColor : TColor;
const in_transparency : integer);
var
x : integer;
y : integer;
p : integer;
begin
ASSERT(in_bitmap.PixelFormat = pf32bit);
for x := 0 to in_bitmap.Width - 1 do
begin
for y := 0 to in_bitmap.Height - 1 do
begin
p := in_bitmap.Canvas.Pixels[x, y];
if TColor(p) <> in_transparentColor then
begin
in_bitmap.Canvas.Pixels[x, y] := p or (in_transparency shl 24);
end
else
in_bitmap.Canvas.Pixels[x, y] := p or ($ff shl 24);
end;
end;
end;
{..............................................................................}
procedure alphaBlendTest(
const in_target : TCanvas;
const in_width : integer;
const in_height : integer);
const
BARSIZE = 30;
var
bitmap : TBitmap;
r : TRect;
blendFn : BLENDFUNCTION;
ret : Boolean;
begin
blendFn.BlendOp := AC_SRC_OVER;
blendFn.SourceConstantAlpha := $ff;
blendFn.BlendFlags := 0;
blendFn.alphaFormat := AC_SRC_ALPHA;
bitmap := TBitmap.Create;
try
bitmap.Width := in_width;
bitmap.Height := in_height;
bitmap.PixelFormat := pf32bit;
bitmap.HandleType := bmDIB;
bitmap.TransparentColor := clFuchsia;
bitmap.Transparent := true;
bitmap.Canvas.Brush.Color := clFuchsia;
bitmap.Canvas.FillRect(Bounds(0, 0, in_width, in_height));
bitmap.Canvas.Brush.Color := clGreen;
r := Bounds(
in_width div 2 - (in_width div 3) div 2,
0,
(in_width div 3) + 1,
BARSIZE + 1);
bitmap.Canvas.Rectangle(r);
// done drawing
//copyToAlpha(bitmap, clFuchsia, 1);
ret := Windows.TransparentBlt(
in_target.Handle,
0,
0,
in_width,
in_height,
bitmap.Canvas.Handle,
0,
0,
in_width,
in_height,
clFuchsia);
//blendFn);
ASSERT(ret);
finally
bitmap.Free;
end;
end;
{..............................................................................}
procedure TfrmMain.PaintBox1Paint(Sender: TObject);
var
r: TRect;
begin
PaintBox1.Canvas.Brush.Color := clBlue;
r := Bounds(0, 0, PaintBox1.ClientWidth, PaintBox1.ClientHeight);
PaintBox1.Canvas.FillRect(r);
PaintBox1.Canvas.Brush.Color := clRed;
PaintBox1.Canvas.Ellipse(0, 0, PaintBox1.ClientWidth, PaintBox1.ClientHeight);
alphaBlendTest(PaintBox1.Canvas, PaintBox1.ClientWidth, PaintBox1.ClientHeight);
end;
end.
Trick: blending the same colors in whatever ratio results in that same color.
So, the simplest way (and maybe also the most efficient) is to first draw the transparented result to a temporary bitmap, and alphablend that bitmap on the destination canvas.
With access to the destination canvas during drawing:
procedure TfrmMain.PaintBox1Paint(Sender: TObject);
const
BarSize = 30;
var
R: TRect;
Bmp: TBitmap;
BlendFunc: TBlendFunction;
begin
with PaintBox1 do
begin
R := ClientRect;
Canvas.Brush.Color := clBlue;
Canvas.FillRect(R);
Canvas.Brush.Color := clRed;
Canvas.Ellipse(R);
Bmp := TBitmap.Create;
try
Bmp.Width := Width;
Bmp.Height := Height;
BitBlt(Bmp.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0,
SRCCOPY);
Bmp.Canvas.Brush.Color := clGreen;
R := Bounds(Width div 3, 0, Width div 3 + 1, BarSize + 1);
Bmp.Canvas.Rectangle(R);
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := 80;
BlendFunc.AlphaFormat := 0;
Windows.AlphaBlend(Canvas.Handle, 0, 0, Width, Height, Bmp.Canvas.Handle,
0, 0, Width, Height, BlendFunc);
finally
Bmp.Free;
end;
end;
end;
And without access to the destination canvas during drawing:
procedure GetRemoteBitmap(Bmp: TBitmap; Width, Height: Integer);
const
BarSize = 30;
var
R: TRect;
begin
Bmp.Canvas.Brush.Color := clFuchsia;
Bmp.Width := Width;
Bmp.Height := Height;
Bmp.TransparentColor := clFuchsia;
Bmp.Transparent := True;
Bmp.Canvas.Brush.Color := clGreen;
R := Bounds(Width div 3, 0, Width div 3 + 1, BarSize + 1);
Bmp.Canvas.Rectangle(R);
end;
procedure TfrmMain.PaintBox1Paint(Sender: TObject);
var
R: TRect;
Bmp: TBitmap;
Tmp: TBitmap;
BlendFunc: TBlendFunction;
begin
with PaintBox1 do
begin
R := ClientRect;
Canvas.Brush.Color := clBlue;
Canvas.FillRect(R);
Canvas.Brush.Color := clRed;
Canvas.Ellipse(R);
Bmp := TBitmap.Create;
Tmp := TBitmap.Create;
try
GetRemoteBitmap(Bmp, Width, Height);
Tmp.Width := Width;
Tmp.Height := Height;
BitBlt(Tmp.Canvas.Handle, 0, 0, Width, Height, Canvas.Handle, 0, 0,
SRCCOPY);
TransparentBlt(Tmp.Canvas.Handle, 0, 0, Width, Height, Bmp.Canvas.Handle,
0, 0, Width, Height, ColorToRGB(clFuchsia));
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := 80;
BlendFunc.AlphaFormat := 0;
Windows.AlphaBlend(Canvas.Handle, 0, 0, Width, Height, Tmp.Canvas.Handle,
0, 0, Width, Height, BlendFunc);
finally
Tmp.Free;
Bmp.Free;
end;
end;
end;
Just for the sake of completeness ("How do I compute the alpha value?"):
procedure alphaBlendTest(
const in_target : TCanvas;
const in_width : integer;
const in_height : integer);
const
BARSIZE = 30;
var
bitmap : TBitmap;
r : TRect;
blendFn : BLENDFUNCTION;
ret : Boolean;
x, y: Integer;
px : PRGBQuad;
begin
blendFn.BlendOp := AC_SRC_OVER;
blendFn.SourceConstantAlpha := $ff;
blendFn.BlendFlags := 0;
blendFn.alphaFormat := AC_SRC_ALPHA;
bitmap := TBitmap.Create;
try
bitmap.Width := in_width;
bitmap.Height := in_height;
bitmap.PixelFormat := pf32bit;
bitmap.Canvas.Brush.Color := clGreen;
r := Bounds(
in_width div 2 - (in_width div 3) div 2,
0,
(in_width div 3) + 1,
BARSIZE + 1);
bitmap.Canvas.Rectangle(r);
for y := 0 to bitmap.Height - 1 do begin
px := bitmap.ScanLine[y];
for x := 0 to Bitmap.Width - 1 do begin
if PtInRect(r, Point(x, y)) then begin
px.rgbBlue := MulDiv(px.rgbBlue, $A0, $FF);
px.rgbGreen := MulDiv(px.rgbGreen, $A0, $FF);
px.rgbRed := MulDiv(px.rgbRed, $A0, $FF);
px.rgbReserved := $A0;
end else
px.rgbReserved := $00; // fully transparent
Inc(px);
end;
end;
// done drawing
ret := Windows.AlphaBlend(
in_target.Handle,
0,
0,
in_width,
in_height,
bitmap.Canvas.Handle,
0,
0,
in_width,
in_height,
blendFn);
ASSERT(ret);
finally
bitmap.Free;
end;
end;

Delphi custom drawing - glowing glass

I have been experimenting a lot with some glassy images, such as the one below, and I got to thinking there's gotta be a way I can put this into code, so I can color it anything I want. It doesn't need to look 100% precisely like the image below, but I'd like to write some code to draw the oval and the glass effect (gradient with some really fancy calculations). I must note clearly that I am horrible with math, and I know this requires some tricky formulas.
Sample of what I'm working on:
The border of the oval is the easy part, the gradient that goes inside the oval from top to bottom is also fairly easy - but when it comes to making the edges fade to make that glassy look along the top and sides - I have no clue how to go about doing this.
Original left edge image:
Whether someone can point me to a good tutorial for this, or if someone wants to demonstrate it, either would be really appreciated.
Here's the procedure I use to draw so far:
//B = Bitmap to draw to
//Col = Color to draw glass image
procedure TForm1.DrawOval(const Col: TColor; var B: TBitmap);
var
C: TCanvas; //Main canvas for drawing easily
R: TRect; //Base rect
R2: TRect; //Working rect
X: Integer; //Main top/bottom gradient loop
CR, CG, CB: Byte; //Base RGB color values
TR, TG, TB: Byte; //Working RGB color values
begin
if assigned(B) then begin
if B <> nil then begin
C:= B.Canvas;
R:= C.ClipRect;
C.Pen.Style:= psClear;
C.Brush.Style:= bsSolid;
C.Brush.Color:= B.TransparentColor;
C.FillRect(R);
C.Pen.Style:= psSolid;
C.Pen.Color:= clBlack;
C.Pen.Width:= 5;
C.Brush.Color:= clBlack;
R2:= R;
for X:= 1 to 6 do begin
R2.Bottom:= R2.Bottom - 1;
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
end;
R2.Left:= R2.Left + 1;
R2.Right:= R2.Right - 1;
C.Brush.Color:= Col;
C.Pen.Width:= 3;
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
C.Brush.Style:= bsSolid;
C.Pen.Style:= psClear;
R2:= R;
R2.Left:= R2.Left + 13;
R2.Right:= R2.Right - 13;
R2.Top:= 3;
R2.Bottom:= (R2.Bottom div 2) - 18;
CR:= GetRValue(Col);
CG:= GetGValue(Col);
CB:= GetBValue(Col);
for X:= 1 to 16 do begin
TR:= EnsureRange(CR + (X * 4)+25, 0, 255);
TG:= EnsureRange(CG + (X * 4)+25, 0, 255);
TB:= EnsureRange(CB + (X * 4)+25, 0, 255);
C.Brush.Color:= RGB(TR, TG, TB);
C.RoundRect(R2.Left, R2.Top, R2.Right, R2.Bottom,
Round(R2.Bottom / 1.5), Round(R2.Bottom / 1.5));
R2.Left:= R2.Left + 2;
R2.Right:= R2.Right - 2;
R2.Bottom:= R2.Bottom - 1;
end;
end;
end;
end;
Ingredients needed:
AlphaBlend for the glassy effect,
GradientFill for the top gradient ellipse,
MaskBlt to exclude non-rectangular already drawn parts when drawing,
indeed some math, pretty easy though.
It is really necessary to devide the drawing task in small steps and place them in the right order. Then this is not as impossible as it at first may seem.
In the code below, I use three temporary bitmaps to reach the end goal:
a memory bitmap on which everything is drawn to reduce flicker,
a temporary bitmap, needed for assistance,
a mask bitmap for storage of a clipping shape.
I do not like comments in code, but I expect it speaks for itself:
unit GlassLabel;
interface
uses
Classes, Controls, Windows, Graphics, Math;
const
DefTransparency = 30;
type
TPercentage = 0..100;
TGlassLabel = class(TGraphicControl)
private
FTransparency: TPercentage;
procedure SetTransparency(Value: TPercentage);
protected
procedure Paint; override;
public
constructor Create(AOwner: TComponent); override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
published
property Caption;
property Color;
property Font;
property Transparency: TPercentage read FTransparency
write SetTransparency default DefTransparency;
end;
implementation
type
PTriVertex = ^TTriVertex;
TTriVertex = record
X: DWORD;
Y: DWORD;
Red: WORD;
Green: WORD;
Blue: WORD;
Alpha: WORD;
end;
TRGB = record
R: Byte;
G: Byte;
B: Byte;
end;
function GradientFill(DC: HDC; Vertex: PTriVertex; NumVertex: ULONG;
Mesh: Pointer; NumMesh, Mode: ULONG): BOOL; stdcall; overload;
external msimg32 name 'GradientFill';
function GradientFill(DC: HDC; const ARect: TRect; StartColor,
EndColor: TColor; Vertical: Boolean): Boolean; overload;
const
Modes: array[Boolean] of ULONG = (GRADIENT_FILL_RECT_H, GRADIENT_FILL_RECT_V);
var
Vertices: array[0..1] of TTriVertex;
GRect: TGradientRect;
begin
Vertices[0].X := ARect.Left;
Vertices[0].Y := ARect.Top;
Vertices[0].Red := GetRValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Green := GetGValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Blue := GetBValue(ColorToRGB(StartColor)) shl 8;
Vertices[0].Alpha := 0;
Vertices[1].X := ARect.Right;
Vertices[1].Y := ARect.Bottom;
Vertices[1].Red := GetRValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Green := GetGValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Blue := GetBValue(ColorToRGB(EndColor)) shl 8;
Vertices[1].Alpha := 0;
GRect.UpperLeft := 0;
GRect.LowerRight := 1;
Result := GradientFill(DC, #Vertices, 2, #GRect, 1, Modes[Vertical]);
end;
function GetRGB(AColor: TColor): TRGB;
begin
AColor := ColorToRGB(AColor);
Result.R := GetRValue(AColor);
Result.G := GetGValue(AColor);
Result.B := GetBValue(AColor);
end;
function MixColor(Base, MixWith: TColor; Factor: Single): TColor;
var
FBase: TRGB;
FMixWith: TRGB;
begin
if Factor <= 0 then
Result := Base
else if Factor >= 1 then
Result := MixWith
else
begin
FBase := GetRGB(Base);
FMixWith := GetRGB(MixWith);
with FBase do
begin
R := R + Round((FMixWith.R - R) * Factor);
G := G + Round((FMixWith.G - G) * Factor);
B := B + Round((FMixWith.B - B) * Factor);
Result := RGB(R, G, B);
end;
end;
end;
function ColorWhiteness(C: TColor): Single;
begin
Result := (GetRValue(C) + GetGValue(C) + GetBValue(C)) / 255 / 3;
end;
function ColorBlackness(C: TColor): Single;
begin
Result := 1 - ColorWhiteness(C);
end;
{ TGlassLabel }
constructor TGlassLabel.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csOpaque];
FTransparency := DefTransparency;
end;
procedure TGlassLabel.Paint;
const
DSTCOPY = $00AA0029;
DrawTextFlags = DT_CENTER or DT_END_ELLIPSIS or DT_SINGLELINE or DT_VCENTER;
var
W: Integer;
H: Integer;
BorderTop: Integer;
BorderBottom: Integer;
BorderSide: Integer;
Shadow: Integer;
R0: TRect; //Bounds of control
R1: TRect; //Inside border
R2: TRect; //Top gradient
R3: TRect; //Text
R4: TRect; //Perforation
ParentDC: HDC;
Tmp: TBitmap;
Mem: TBitmap;
Msk: TBitmap;
ShadowFactor: Single;
X: Integer;
BlendFunc: TBlendFunction;
procedure PrepareBitmaps;
begin
Tmp.Width := W;
Tmp.Height := H;
Mem.Canvas.Brush.Color := Color;
Mem.Width := W;
Mem.Height := H;
Mem.Canvas.Brush.Style := bsClear;
Msk.Width := W;
Msk.Height := H;
Msk.Monochrome := True;
end;
procedure PrepareMask(R: TRect);
var
Radius: Integer;
begin
Radius := (R.Bottom - R.Top) div 2;
Msk.Canvas.Brush.Color := clBlack;
Msk.Canvas.FillRect(R0);
Msk.Canvas.Brush.Color := clWhite;
Msk.Canvas.Ellipse(R.Left, R.Top, R.Left + 2 * Radius, R.Bottom);
Msk.Canvas.Ellipse(R.Right - 2 * Radius, R.Top, R.Right, R.Bottom);
Msk.Canvas.FillRect(Rect(R.Left + Radius, R.Top, R.Right - Radius,
R.Bottom));
end;
procedure DrawTopGradientEllipse;
begin
GradientFill(Tmp.Canvas.Handle, R2, MixColor(Color, clWhite, 1.0),
MixColor(Color, clWhite, 0.2), True);
PrepareMask(R2);
MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
Msk.Handle, 0, 0, MakeROP4(SRCCOPY, DSTCOPY));
end;
procedure DrawPerforation;
begin
while R4.Right < (W - H div 2) do
begin
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.9);
Mem.Canvas.RoundRect(R4.Left, R4.Top, R4.Right, R4.Bottom, H div 7,
H div 7);
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.5);
Mem.Canvas.RoundRect(R4.Left + 1, R4.Top + 1, R4.Right - 1,
R4.Bottom - 1, H div 7 - 1, H div 7 - 1);
Mem.Canvas.Pen.Color := MixColor(Color, clWhite, 0.33);
Mem.Canvas.MoveTo(R4.Left + H div 14, R4.Top + 1);
Mem.Canvas.LineTo(R4.Right - H div 14, R4.Top + 1);
OffsetRect(R4, R4.Right - R4.Left + H div 12, 0);
end;
end;
procedure DrawCaption;
begin
Mem.Canvas.Font := Font;
ShadowFactor := 0.6 + 0.4 * (Min(1.0, ColorBlackness(Font.Color) + 0.3));
Mem.Canvas.Font.Color := MixColor(Font.Color, clBlack, ShadowFactor);
DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
OffsetRect(R3, -Shadow, Shadow);
Mem.Canvas.Font.Color := Font.Color;
DrawText(Mem.Canvas.Handle, PChar(Caption), -1, R3, DrawTextFlags);
end;
procedure DrawBorderAlias;
begin
Mem.Canvas.Pen.Color := MixColor(Color, clBlack, 0.65);
X := R1.Left + (R1.Bottom - R1.Top) div 2 + 2;
Mem.Canvas.Arc(R1.Left + 1, R1.Top, R1.Left + R1.Bottom - R1.Top + 1,
R1.Bottom, X, 0, X, H);
X := R1.Right - (R1.Bottom - R1.Top) div 2 - 2;
Mem.Canvas.Arc(R1.Right - 1, R1.Top, R1.Right - R1.Bottom + R1.Top - 1,
R1.Bottom, X, H, X, 0);
end;
procedure DrawBorder;
begin
PrepareMask(R1);
Tmp.Canvas.Brush.Color := clWhite;
Tmp.Canvas.Draw(0, 0, Msk);
BitBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, SRCAND);
end;
procedure DrawCombineParent;
begin
BitBlt(Tmp.Canvas.Handle, 0, 0, W, H, ParentDC, Left, Top, SRCCOPY);
BlendFunc.BlendOp := AC_SRC_OVER;
BlendFunc.BlendFlags := 0;
BlendFunc.SourceConstantAlpha := Round(FTransparency * High(Byte) / 100);
BlendFunc.AlphaFormat := 0;
AlphaBlend(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0, W, H,
BlendFunc);
PrepareMask(R0);
MaskBlt(Mem.Canvas.Handle, 0, 0, W, H, Tmp.Canvas.Handle, 0, 0,
Msk.Handle, 0, 0, MakeROP4(DSTCOPY, SRCCOPY));
end;
begin
if HasParent and (Height > 1) then
begin
W := Width;
H := Height;
BorderTop := Max(1, H div 30);
BorderBottom := Max(2, H div 10);
BorderSide := (BorderTop + BorderBottom) div 2;
Shadow := Font.Size div 8;
R0 := ClientRect;
R1 := Rect(BorderSide, BorderTop, W - BorderSide, H - BorderBottom);
R2 := Rect(R1.Left + BorderSide + 1, R1.Top, R1.Right - BorderSide - 1,
R1.Top + H div 4);
R3 := Rect(H div 2 + 1 + Shadow, R1.Top + 1, W - H div 2 - 1,
R1.Bottom - Shadow);
R4 := Bounds(H div 2, R1.Bottom - H div 4 + 1, H div 5, H div 4 - 2);
ParentDC := GetDC(Parent.Handle);
Tmp := TBitmap.Create;
Mem := TBitmap.Create;
Msk := TBitmap.Create;
try
PrepareBitmaps;
DrawTopGradientEllipse;
DrawPerforation;
DrawCaption;
DrawBorderAlias;
DrawBorder;
DrawCombineParent;
BitBlt(Canvas.Handle, 0, 0, W, H, Mem.Canvas.Handle, 0, 0, SRCCOPY);
finally
Msk.Free;
Mem.Free;
Tmp.Free;
ReleaseDC(Parent.Handle, ParentDC);
end;
end;
end;
procedure TGlassLabel.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
if AWidth < AHeight then
AWidth := AHeight;
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;
procedure TGlassLabel.SetTransparency(Value: TPercentage);
begin
if FTransparency <> Value then
begin
FTransparency := Value;
Invalidate;
end;
end;
end.
Sample code to produce the above (place an TImage control in the background):
procedure TForm1.FormCreate(Sender: TObject);
begin
Font.Size := 16;
Font.Color := $00A5781B;
Font.Name := 'Calibri';
Font.Style := [fsBold];
with TGlassLabel.Create(Self) do
begin
SetBounds(40, 40, 550, 60);
Color := $00271907;
Caption := '395 Days, 22 Hours, 0 Minutes, 54 Seconds';
Parent := Self;
end;
with TGlassLabel.Create(Self) do
begin
SetBounds(40, 40 + 119, 550, 60);
Color := $00000097;
Caption := '0 Days, 1 Hours, 59 Minutes, 31 Seconds';
Parent := Self;
end;
end;
Tweak as you like.
First you need to draw some image. It can have gradients, transparency, etc. Then you will need to convert it to bitmap and for each pixel use GraphUtil.ColorRGBToHLS/ColorHLSToRGB functions. In your case you will need to change only hue of each pixel.

Resources