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;

Answer 1

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.

Answer 2

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.