Delphi custom drawing - glowing glass

Question

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;

Corelli

Maybe you can get some inspiration from this component by Roy M Klever, rkGlassButton – Crab

Bojan Mitov has made a free GDI+ component which can simplify antialiasing and smooth fading of colours. – Crab

By the way, just wondering if anyone noticed anything fishy about how many days it's counting down to....... – Corelli

Please note: I just asked another question deriving from this one: #8292169 – Corelli

NOTE: I have posted the new source code for this project on another website based on NGLN's code below: tek-tips.com/faqs.cfm?fid=7529 – Corelli

Answer 1

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.

Swashbuckler

+1. Thanks for posting this. You might want to post sample use code that produces something similar to the image you posted. If you'd like, I can also post code for the package and component registration that allows this to be dropped on the form in the IDE. – Knop

+1 (only), because I can't vote more than once for the answer – Flasher

Not sure why I didn't see this answer sooner - Accepted. – Corelli

That's just simply beautifully done, lots to work with. My next step will be encapsulating all this inside of a DLL. – Corelli

@KenWhite: Actually, no need to, it's a component. Just was missing the Register procedure. Register it in a package and wham bam thank you ma'am! (or Sir, rather) – Corelli

By the way, technically speaking, the property Transparency should rather be Opacity. – Corelli

Actually nevermind that last comment, I didn't realize something, instead of re-drawing in place of the old one, it's drawing over the old one, so even when I set the transparency to a lower number, it just keeps getting darker and darker (or more opaque). How to make sure it gets completely re-drawn? – Corelli

Just noticed - I have that problem when I DON'T have any image behind it - but when there is, it shows fine (although a bit of a flicker). – Corelli

What makes your answer even sweeter is the fact that you made most of it independent from the actual component - meaning, you make use of HDC. I've already managed to migrate all this into a DLL and have a wrapper component already working. – Corelli

Please note: I just asked another question deriving from this one: #8292169 – Corelli

@NGLN: Just to note, I've posted a much more recent copy of this project here: tek-tips.com/faqs.cfm?fid=7529 – Corelli

Answer 2

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.

Pleat

In this case, I don't want any original image, for example, I may want to dynamically change the degree of the curved edge, or change the amount of glow in the upper area without changing the color in the lower area, or just change the border color, etc... That was my first idea too, but I don't want any original images. – Corelli

Than standard graphics will not be enough. You will need something like Graphics32: sourceforge.net/projects/graphics32 – Pleat