Custom title bars – reprise

It’s been several months, but as a small follow up to my Vista/Windows 7 custom title bar posts back last spring, I’ve finally been able to fix a bug that the code exhibited when running on 64 bit versions of Windows 7 (and quite possibly Vista too, though no one reported that) — for in short, you could quite easy get ‘ghost’ buttons appear:

The fix ended up being to amend the WM_NCHITTEST handler to never return HTMINBUTTON, HTMAXBUTTON or HTCLOSE, and I’ve edited my original post to reflect this. I’ve also fixed the small demo I wrote afterwards, adding to it an even smaller console application to patch an EXE to require Vista or later, which allows the full range of form border styles to be customised (the demo is downloadable here).

Custom drawing on glass (2)

In my previous post, I both introduced the topic of custom drawing on glass, and looked at basic bitmap drawing specifically. In this one, I’ll look in more detail at the other ‘classic GDI’ techniques I mentioned there, namely using icons, image lists, the theming API and brushes. I’ll also briefly look at generating custom bitmaps at runtime too.

Icons and image lists

If you want to draw to glass, you need 32 bit images, and one form these may take is that of the good old ICO format, which has supported 32 bit colour entries since Windows XP. As the VCL’s TIcon class is a fairly thin wrapper round the HICON API, it therefore essentially supports them by default. Vista also brought ‘large’ (i.e., 256×256 PNG encoded) icons, which TIcon – at least until XE according to QC86768 – didn’t reliably wrap however. If it works though, use of a 32 bit icon is pretty simple – first load it into a TIcon instance in the normal way, and then secondly draw it in the normal way, whether by calling Canvas.Draw or the DrawIconEx API function. Unlike the case of raw bitmaps, there’s no need to worry about pixel pre-multiplication.

One thing to watch out for, though, is how D2007’s TIcon at least can fail to report the icon size correctly for 32 bit colour icons. This then causes an issue with TImageList, since if you attempt to call TImageList’s AddIcon method when passing in a 32 bit icon, an exception is likely to be raised complaining that the icon is the wrong size.

As a matter of fact, this exception is completely unnecessary even when it is accurate, since TImageList merely wraps the HIMAGELIST API, and the HIMAGELIST API will internally resize copied icons as appropriate anyhow. Consequently, a quick and easy workaround for the bug is something like this [edit: see note at the end for an explanation]:

uses CommCtrl, Graphics, ImgList;

type
  TImageListAddIconFixer = class helper for TCustomImageList
  public
    function AddIcon(Image: TIcon): Integer;
  end;

function TImageListAddIconFixer.AddIcon(Image: TIcon): Integer;
begin
  if Image = nil then
    Result := Add(nil, nil)
  else
  begin
    Result := ImageList_AddIcon(Handle, Image.Handle);
    Change;
  end;
end;

With respect to image lists themselves, successfully loading 32 bit icons into one requires the image list to itself be 32 bit. This is only possible when Windows theming is enabled and used – even D2009 and above, which surfaces the functionality, does not abstract from this limitation, so you may find yourself needing two sets of image lists, one ‘best looking’ set for when theming is active and a regular 24 bit colour one for when it is not.

That caveat aside, creating a fresh 32 bit image list is quite simple – in D2009 or later, set a TImageList’s ColorDepth property to cd32bit. In D2007, you’ll have to call the ImageList_Create function directly, assigning the result to the Handle property of a TImageList instance:

uses CommCtrl;

with MyImageList do
Handle := ImageList_Create(Width, Height, ILC_COLOR32 or ILC_MASK, AllocBy, AllocBy)

Using 24 bit (or less) colour image lists

In practice – or at least, from the custom control writer’s point of view – the problem with image lists and glass will be less in creating 32 bit colour image lists, but in making use of lesser colour ones. In short, do nothing special, and you’ll be drawing images like this

when what you really want is this

While it may be considered a bit simplistic, the best workaround, I suggest, is to simply draw to a temporary 32 bit bitmap first, manually set the alpha channel, then alpha blend the bitmap to the screen:

procedure ClearRGBQuad(var Q: TRGBQuad); inline;
begin
  LongWord(Q) := 0;
end;

function SameRGBQuad(const Q1, Q2: TRGBQuad): Boolean; inline;
begin
  Result := LongWord(Q1) = LongWord(Q2);
end;

procedure DrawImageListWithAlpha(ImageList: TCustomImageList; Canvas: TCanvas;
  DestX, DestY: Integer; ImageIndex: TImageIndex);
const
  MergeFunc: TBlendFunction = (BlendOp: AC_SRC_OVER; BlendFlags: 0;
  SourceConstantAlpha: 255; AlphaFormat: AC_SRC_ALPHA);
const
  TransPixel: TRGBQuad = (rgbBlue: $FE; rgbGreen: $00; rgbRed: $FF; rgbReserved: $00);
var
  Buffer: TBitmap;
  PixelPtr: PRGBQuad;
  X, Y: Integer;
begin
  {$IF DECLARED(cd32Bit)}
  if ImageList.ColorDepth = cd32Bit then
  begin
    ImageList.Draw(Canvas, DestX, DestY, ImageIndex, dsTransparent, itImage);
    Exit;
  end;
  {$IFEND}
  Buffer := TBitmap.Create;
  try
    Buffer.Canvas.Brush.Color := RGB(TransPixel.rgbRed,
      TransPixel.rgbGreen, TransPixel.rgbBlue);
    Buffer.PixelFormat := pf32bit;
    Buffer.SetSize(ImageList.Width, ImageList.Height);
    ImageList.Draw(Buffer.Canvas, 0, 0, ImageIndex, dsTransparent, itImage);
    for Y := Buffer.Height - 1 downto 0 do
    begin
      PixelPtr := Buffer.ScanLine[Y];
      for X := Buffer.Width - 1 downto 0 do
      begin
        if SameRGBQuad(PixelPtr^, TransPixel) then
          ClearRGBQuad(PixelPtr^)
        else
          PixelPtr.rgbReserved := $FF;
        Inc(PixelPtr);
      end;
    end;
    AlphaBlend(Canvas.Handle, DestX, DestY, ImageList.Width, ImageList.Height,
      Buffer.Canvas.Handle, 0, 0, ImageList.Width, ImageList.Height, MergeFunc)
  finally
    Buffer.Free;
  end;
end;

If you’re wondering, the values of TransPixel add up to a colour that is almost-but-not-quite clFushia, which I’ve chosen quite arbitrarily. Note too that the byte order of a TRGBQuad – which defines a single pixel in a 32 bit Windows bitmap – is different to the byte order of a GDI colour value (and therefore, TColor): confusingly enough, TRGBQuad has a byte order of blue-green-red-alpha, not red-green-blue-alpha.

Naturally, if you’re dealing with massive images, the approach taken above would be problematic. Given image lists typically contain only very small images though, it should work fine.

Theming API

In the main, the Windows theming API is helpfully wrapped by the ThemeServices singleton object in Themes.pas, though as always, you can always call it directly of course. If you want to understand its general use, check out the source for something like TSpeedButton or TBitBtn, which uses the theming API when available.

One important function that is probably not wrapped by Themes.pas, however, is DrawThemeTextEx. The significance of this function – which was introduced in Vista – is that it enables you to define an outlining ‘glow’ that is frequently necessary to make the drawn text readable on glass, especially when what is behind the form is dark –

To make it easy to use, you might write a simple wrapper function like the following:

uses Types, UxTheme, Themes, Graphics;

procedure DrawGlassText(Canvas: TCanvas; GlowSize: Integer; var Rect: TRect;
  var Text: UnicodeString; Format: DWORD); overload;
var
  DTTOpts: TDTTOpts;
begin
  if Win32MajorVersion < 6 then
  begin
    DrawTextW(Canvas.Handle, PWideChar(Text), Length(Text), Rect, Format);
    Exit;
  end;
  ZeroMemory(@DTTOpts, SizeOf(DTTOpts));
  DTTOpts.dwSize := SizeOf(DTTOpts);
  DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
  if Format and DT_CALCRECT = DT_CALCRECT then
    DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_CALCRECT;
  DTTOpts.crText := ColorToRGB(Canvas.Font.Color);
  if GlowSize > 0 then
  begin
    DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
    DTTOpts.iGlowSize := GlowSize;
  end;
  with ThemeServices.GetElementDetails(teEditTextNormal) do
    DrawThemeTextEx(ThemeServices.Theme[teEdit], Canvas.Handle, Part, State,
      PWideChar(Text), Length(Text), Format, @Rect, DTTOpts);
end;

It would probably be sensible if Embarcadero added an overload of TCanvas.TextRect that calls DrawThemeTextEx, though especially if you define a wrapper like the above, it’s not difficult to use directly if you’re accustomed to the older DrawText API function.

Brushes

Simply put, TBrush by default will be alpha channel ignorant, making the FillRect and FrameRect methods of TCanvas useless when drawing to glass. However, by dint of Windows allowing a brush to be created from a device independent bitmap (DIB), it is in fact possible to create solid brushes that have an alpha channel. Annoyingly however, you can’t just use the Bitmap property of TBrush to set this up, since TBrush internally forceably converts any source bitmap to a device dependent one (DDB) – basically, when Delphi 1 was released, the Windows API only supported creating brushes from DDBs, and the VCL has never been updated to no longer adhere to this dead requirement. Because of this, you’ll need to dip into the using Windows API directly.

Once again though, that’s not too tricky once you know what exactly to call, which is the CreateDIBPatternBrushPt API function. To create a simple, alpha-aware brush, this function needs to be passed the definition of a 32 bit, 1×1 pixel DIB, as defined in a TBitmapInfo record. The result can then be assigned to the Handle property of a TBrush instance, or used directly if you prefer.

Similar to the case of calling the AlphaBlend API function however, the pixel so defined needs to be ‘premultiplied’, i.e., factored by the alpha channel value as a proportion of 100% solid. Putting this info all together leads to something like this:

function CreatePreMultipliedRGBQuad(Color: TColor; Alpha: Byte = $FF): TRGBQuad;
begin
  Color := ColorToRGB(Color);
  Result.rgbBlue := MulDiv(GetBValue(Color), Alpha, $FF);
  Result.rgbGreen := MulDiv(GetGValue(Color), Alpha, $FF);
  Result.rgbRed := MulDiv(GetRValue(Color), Alpha, $FF);
  Result.rgbReserved := Alpha;
end;

function CreateSolidBrushWithAlpha(Color: TColor; Alpha: Byte = $FF): HBRUSH;
var
  Info: TBitmapInfo;
begin
  FillChar(Info, SizeOf(Info), 0);
  Info.bmiHeader.biSize := SizeOf(Info.bmiHeader);
  Info.bmiHeader.biWidth := 1;
  Info.bmiHeader.biHeight := 1;
  Info.bmiHeader.biPlanes := 1;
  Info.bmiHeader.biBitCount := 32;
  Info.bmiHeader.biCompression := BI_RGB;
  Info.bmiColors[0] := CreatePreMultipliedRGBQuad(Color, Alpha);
  Result := CreateDIBPatternBrushPt(@Info, 0);
end;

CreateSolidBrushWithAlpha can then be used as thus:

procedure TfrmMain.pbxBrushesPaint(Sender: TObject);
var
  R: TRect;
begin
  R := pbxBrushes.ClientRect;
  with pbxBrushes.Canvas do
  begin
    Brush.Handle := CreateSolidBrushWithAlpha(clGray);
    FrameRect(R);
    InflateRect(R, -2, -2);
    Brush.Handle := CreateSolidBrushWithAlpha(clBlack);
    FrameRect(R);
    InflateRect(R, -1, -1);
    Brush.Handle := CreateSolidBrushWithAlpha(clRed, 100);
    FillRect(R);
  end;
end;

Try it out, and you should get something like this (pbxBrushes should be a TPaintBox, if you can’t guess):

Custom bitmap creation

One last thing to mention is that if you need a little more than boxes, you can always create a custom bitmap at runtime. The drill here is to create a TBitmap instance, set its PixelFormat property to pf32Bit, set its size, then use its ScanLine property to set its pixels as required. This can be a little bit tedious for sure, but it’s a useful option to have.

As an example, here is some code that fills a paint box (pbxScanLine) with a gradient that goes from transparent to solid blue. As only a simple linear gradient is required, a bitmap 1 pixel thick is created then stretched in the AlphaBlend call (please see above for the CreatePreMultipliedRGBQuad function):

type
  PRGBQuadArray = ^TRGBQuadArray;
  TRGBQuadArray = array[0..$FFFFFFF] of TRGBQuad;

procedure TfrmMain.pbxScanLinePaint(Sender: TObject);
const
  MergeFunc: TBlendFunction = (BlendOp: AC_SRC_OVER; BlendFlags: 0;
    SourceConstantAlpha: $FF; AlphaFormat: AC_SRC_ALPHA);
var
  Bitmap: TBitmap;
  Pixels: PRGBQuadArray;
  X: Integer;
begin
  Bitmap := TBitmap.Create;
  try
    Bitmap.PixelFormat := pf32bit;
    Bitmap.SetSize(pbxScanLine.Width, 1);
    Pixels := Bitmap.ScanLine[0];
    for X := Bitmap.Width - 1 downto 0 do
      Pixels[X] := CreatePreMultipliedRGBQuad(clNavy, ($FF * X) div Pred(Bitmap.Width));
    Windows.AlphaBlend(pbxScanLine.Canvas.Handle, 0, 0, pbxScanLine.Width,
      pbxScanLine.Height, Bitmap.Canvas.Handle, 0, 0, Bitmap.Width, Bitmap.Height,
      MergeFunc);
  finally
    Bitmap.Free;
  end;
end;

That’s all for this post. I have however put up on CodeCentral a small demo that shows the various techniques discussed – download it from here.

[* Edit 29/1/11: I see this post has been referenced on StackOverflow regarding the first image list issue discussed (at my time of writing, I’m talking about the questioner’s own answer to this question). To be clear, the image list fixing code is a class helper, the idea being to include it in a unit that is then added to the uses clause of your main unit(s) after Controls and ImgList. If you’re using D7 or earlier, or simply dislike class helpers, you should just use ImageList_Add directly — the thought behind the class helper is simply to allow you to continue to use a TImageList entirely normally. In particular, in D7 or earlier, don’t change the class helper to a regular class and then use it by casting from a regular TImageList.]

Custom drawing on glass (1)

As I noted in a previous post, large parts of the classic GDI (and therefore, TCanvas and its associated classes) are not alpha-channel aware, being as a result not suitable for drawing on glass. Because of this, if you actually want to make use of the GlassFrame property of TForm, it is frequently advisable to use another drawing API, specifically GDI+ or Direct2D – at present, GDI+ can be used via various header translations and open source wrappers (just Google ‘Delphi GDI+’), and Delphi 2010 gets you Direct2D support (for earlier versions, you can grab an API translation by John Bladen here). Nonetheless, there are some glass-friendly aspects to the classic GDI, and if you’re just looking to make some custom VCL controls paint nicely on glass, they can be all you actually need.

Now in summary, ‘what works’ is drawing 32 bit bitmaps, icons and image lists, together with the visual theming API, notwithstanding the fact that many native controls (which, one would assume, internally use said API) frequently don’t work too well. Given the theming API includes a function for outputting text, and filled boxes can be drawn with brushes that use a 32 bit bitmap, you’ve got a fair bit. I’ll take each in turn – bitmaps in this post, the rest next time.

Bitmaps

While this is hopefully quite an obvious point to make, the storage format of a 32 bit colour image need have nothing to do with its in-memory format, which for a GDI application will have to be a particular variant of the Windows Device Independent Bitmap (DIB) format. That said, PNG resources make for a sensible storage format, and the VCL’s TBitmap class largely frees you from having to know about DIBs explicitly.

Use of PNG images does of course require a PNG support library though. Nonetheless, D2009 and greater includes one in the box, and for D2007, you can use Mike Lische’s MPL-licensed GraphicEx – in either case, support is implemented in the form of a handy TGraphic descendant, which you can either draw directly or by assigning to a TBitmap first and then drawing that.

For the actual painting, the key API function is AlphaBlend. Whilst this is called as appropriate by the D2009+ VCL I believe, you’ll definitely need to call it explicitly in D2007. It is pretty easy to use though, excepting one small quirk (if you can call it that) – namely, it requires the source bitmap to have had its pixels ‘pre-multiplied’. For a proper explanation of this, check out Anders Melander’s excellent two part article on writing an alpha-blended splash screen. The short version is that the red, blue and green component values of each pixel need to have been factored by the pixel’s opaqueness before AlphaBlend is called –

procedure PreMultiplyBitmap(Bitmap: TBitmap);
var
  X, Y: Integer;
  Pixel: PRGBQuad;
begin
  Assert(Bitmap.PixelFormat = pf32Bit);
  with Bitmap do
    for Y := Height - 1 downto 0 do
    begin
      Pixel := ScanLine[Y];
      for X := Width - 1 downto 0 do
      begin
        Pixel.rgbBlue := MulDiv(Pixel.rgbBlue, Pixel.rgbReserved, 255);
        Pixel.rgbGreen := MulDiv(Pixel.rgbGreen, Pixel.rgbReserved, 255);
        Pixel.rgbRed := MulDiv(Pixel.rgbRed, Pixel.rgbReserved, 255);
        Inc(Pixel);
      end;
    end;
end;

While in D2009+ you probably won’t have to worry about this, the 32 bit bitmaps produced by the PNG support in GraphicEx will need pre-multiplying.

With a pre-multiplied bitmap at the ready however, an alpha channel aware version of TCanvas.CopyRect goes like this:

procedure CopyRectAlpha(DestCanvas: TCanvas; const DestRect: TRect;
  SourceCanvas: TCanvas; const SourceRect: TRect);
const
  MergeFunc: TBlendFunction = (BlendOp: AC_SRC_OVER; BlendFlags: 0;
  SourceConstantAlpha: 255; AlphaFormat: AC_SRC_ALPHA);
begin
  AlphaBlend(DestCanvas.Canvas.Handle, DestRect.Left, DestRect.Top,
    DestRect.Right - DestRect.Left, DestRect.Bottom - DestRect.Top,
    SourceCanvas.Handle, SourceRect.Left, SourceRect.Top, SourceRect.Right -
    SourceRect.Left, SourceRect.Bottom - SourceRect.Top, MergeFunc);
end;

Pretty simple, eh?

That said, you might not actually be needing to use AlphaBlend at all, since BitBlt, StretchBlt (and therefore, their VCL wrappers such as TCanvas.CopyRect) work with 32 bit bitmaps as well. There is a key difference here with AlphaBlend however: for when blitting (copying) a 32 bit bitmap to glass, a transparent pixel of the bitmap will reset the corresponding glass pixel. In contrast, when blending a 32 bit bitmap to glass, a transparent pixel of the bitmap will leave the glass pixel as it was. With respect to only partially transparent pixels, both functions will ‘blend’ the pixels concerned in a sense. Where AlphaBlend will merge the bitmap’s pixels with what was painted to the glass before, however, BitBlt/StretchBitBlt will in effect ‘reset’ the glass first then merge the pixels.

Put in more practical terms, say you wanted to create a simple animation that paints to a potentially glassy area of the form. When painting a new frame, and using traditional GDI practice, you would typically create a buffer bitmap, drawing the new frame image onto it, before painting the buffer to the form’s Canvas, overwriting what was there before. Essentially, revising such code to be glass-friendly should not take much at all – the only difference should be in initialising the buffer to be all ‘black’ (i.e., 100% transparent in alpha-land) rather than the colour of the form or whatever. In particular, the fact that you may now be painting to glass does not change the fact that the last stage is one of overwriting, and therefore, one for which BitBlt, StretchBlt or one of their VCL equivalents remains appropriate, not AlphaBlend:

Buffer := TBitmap.Create;
try
  if GlassFrame.FrameExtended then
    Buffer.Canvas.Brush.Color := clBlack //i.e., 100% 'transparent'
  else
    Buffer.Canvas.Brush.Assign(Self.Brush);
  Buffer.SetSize(BufferRect.Right - BufferRect.Left, BufferRect.Bottom - BufferRect.Top);
  //
  Canvas.StretchDraw(BufferRect, Buffer);  //overwrite, not blend!
finally
  Buffer.Free;
end;

I’ve demonstrated this in more detail in a small demo, which you can download from here. Basically, it’s just a form with its GlassFrame.SheetOfGlass property set to True, and a spinning Delphi 2010 icon that is moveable using the arrow keys (hold down the Control key to speed it up). Pressing ‘G’ will toggle extended glass on/off, demonstrating how there’s nothing particularly special going on in the drawing code to support glass. Please note that when compiling under D2007, GraphicEx is used, so if you're a D2007 user, download that first (alternative download site here - scroll down a bit), if you haven't a copy on your library path already.

Controls and glass

Looking on Stack Overflow, I’ve just noticed a rather detailed question (really, set of questions) about Aero glass. As it currently stands, the question bears some misconceptions – for example, the questioner makes the false assertion that the VCL DoubleBuffered property ‘sets a window style bit used by the common controls library’. Nonetheless, it’s tweaked me into finishing a couple of posts I intended to follow on from my earlier ones about custom DWM title bars. So, without further ado, here’s the first…

Standard controls and glass

A basic issue with glass frames is that native Windows controls don’t paint very well to them. The reason for this is that these controls still use the drawing primitives of the ‘classic’ GDI (Graphics Device Interface), and these primitives (in the main) ignore alpha channels, despite the fact that respecting alpha channels is essential to playing nicely with glass. Since most standard VCL controls are simply wrappers round their native equivalent (a TEdit is really a single-line native EDIT control, for instance), they inherit this problem. Moreover, the fact that TCanvas and related classes (TBrush etc) wrap the GDI API means that regular custom drawing in Delphi will be glass-hostile by default as well.

Nonetheless, Delphi 2007 slightly repurposed an old feature – optional double-buffering, first introduced in something like Delphi 4 – to provide a general (if by no means foolproof) solution to this. In short, simply turn on the DoubleBuffered property of a control (in Delphi 2009 or later, this will percolate down child controls so long as their ParentDoubleBuffered property is kept set to True), and the VCL will get the control to paint to a bitmap first, a bitmap that will have its alpha channel set to all opaque just before it is blitted to the screen.

In effect, this makes something visibly rectangular like an edit box paint very nicely on glass. Why ‘visibly rectangular’ though? Because, as said, the buffer is made completely opaque before being drawn. Why is that necessary though? Because, as said, the main drawing is more than likely to be done using classic GDI primitives (be it explicitly or implicitly), and thus, using functions that will mess up the alpha channel when called. By making the buffer all opaque at the end, then, this mess is cleared up.

To be clear, it is not double-buffering as such that is the solution here. Indeed, to my eyes, it seems many standard controls at the API level implement their own double-buffering when theming is turned on, yet don’t paint correctly on glass even so – to get things to work, then, you still need to turn on the VCL-level double buffering. Basically, glass-friendly double-buffering need to be performed using a 32 bit bitmap, preferably with special API functions that MS provided for the task in Vista – and while the VCL will internally use these functions as appropriate, the standard controls themselves will not.

Unfortunately, simply asserting the need for VCL-level double buffering is not the end of the matter though. One thing you may find, for example, is that simply enabling any sort of extended glass frame is liable to cause flicker where there was none before, even when a control is not actually on glass and the DoubleBuffered property of both the form and controls is correctly set. Quite frankly, solving this just takes trial and error. Here’s a few notes about certain standard controls though:

TBitBtn

Works fine in Delphi XE, assuming DoubleBuffered is True. In D2007 (I don’t know about versions in between) it shows a thin solid border on glass.

TButton

Setting DoubleBuffered to True causes the control to lose its fade in/out effects, so if a TButton isn’t actually on glass, I’d suggest making sure its DoubleBuffered stays False. Since when put on glass it shows a thin solid border (the curse of built-in yet not glass-aware double buffering strikes again…), its probably better to keep it off of the stuff anyhow — use TBitBtn instead.

TComoboBox, TEdit, TMemo

Basically works fine, though text selection can be a bit flickery.

TFrame

Set its ParentBackground property to False to avoid flicker.

TGroupBox

Set its ParentBackground property to False to avoid its caption flickering.

TListBox

Basically fine, though its border practically disappears due to it being in the control’s non-client area, and therefore, outside of the double-buffered area.

TImage

Whether the picture displays correctly is entirely down to the graphic type. Use a PNG image (in Delphi 2007, you’ll have to find a copy of the code that was integrated into the next version – it was open source), and you should be be fine. Similarly, in recent Delphi versions, a 32 bit TBitmap with its alpha channel properly set should be fine too.

TProgressBar

Its own internal double buffering at the API level paints things fine, and the VCL level one only messes things up, so make sure its DoubleBuffered property stays False even when an instance is placed on glass.

TRadioGroup

Set its ParentBackground property to False to avoid its caption flickering; add csAcceptControls to its ControlStyle property before its handle gets created to prevent its radio buttons from flickering.

TRichEdit

Doesn’t work with VCL double buffering at all, so make sure its DoubleBuffered property (stays) False.

TSpeedButton

Text-only speed buttons paint fine, both in the push and tool button styles, since the VCL delegates to the (alpha channel-aware) theming API.  Set the Glyph property though, and things immediately go downhill; thanks to convoluted internals added in D3 or D4, it’s also very difficult to fix. If you want a speed button with an image to go on glass, then I suggest you write your own.

TToolBar

I’ve given up trying to make a transparent TToolBar work on glass – the control’s own double buffering at the API level just gets terribly confused. To get it to work at all, you have to get its background explicitly filled. This can be done either by enabling the gradient background style (said style being implemented at the VCL level), or by handling the OnCustomDraw event as thus:

Sender.Canvas.FillRect(Sender.ClientRect);

General tips

As implied above, for a flickering parent control on glass, two things to always try is to (a) set its ParentBackground property to False and (b) ensure that csAcceptsControls is included in its ControlStyle property. The latter causes the WS_CLIPCHILDREN window style to be set, which makes a big difference (in my view, it’s arguably a bug that this just isn’t always set, notwithstanding the fact that back in 1995, there may have been efficiencies involved not to). Also, in the main, you should always turn on the VCL’s double buffering, notwithstanding the odd exception mentioned.

Separately, for controls generally, the Stack Overflow question linked to above alludes to a SetLayeredWindowAttributes hack. Unfortunately, this only worked with certain Vista betas – by the time the RTM build came round, MS deliberately prevented the hack from working.

Lastly, an alternative to using the VCL’s double-buffering is to set the WS_EX_COMPOSITED extended window style for all top-level windowed controls. Don’t just set this for the form itself, however, since the style isn’t glass aware as such – in other words, whenever GlassFrame.Enabled is True, the form’s DoubleBuffered property should be True too even if no sub-control’s DoubleBuffered property is likewise.

Note that the big point against using the extended window style is that every child control (and every grandchild etc) will be forced into participating, unlike in the case of the DoubleBuffered property. While I haven’t come any across straghtforward incompatibilities a la the VCL’s double-buffering implementation and TToolBar, you will kill off a lot of the fancy fading effects that many standard controls now implement even so.

[Edit (29/7/10): fixed typo (thanks Will in the comments) and added a bit more on WS_EX_COMPOSITED.]

[Edit (9/4/10): added about TBitBtn, which now works in XE at least.]

Setting up a custom title bar – reprise

As a follow up to my last post, I’ve written a small demo that (rather pointlessly of course) enables custom drawing in the main form’s title bar only to reinstate the standard elements. It does this across changes to the form’s BorderIcons, BorderStyle, Caption and Icon properties, and has a check box to allow easily comparing to the ‘real thing’:

The substantive code is essentially the same as what I presented last time, though one small but important thing it adds is a couple of lines to combat the problem of changed client coordinates.

If you recall, this was the issue of how in enabling custom drawing on a form’s title bar, you must extend its client area onto it, messing up the position of child controls in the process. While merely taking away the top part of the non-client area was better than the MSDN-suggested solution of zapping the non-client area entirely, the problem did still remain.

A good way to counteract it, though, is to do two things: (1) move all non-aligned controls over to a frame, which is then top-aligned to the form; and (2) override the form’s AdjustClientArea method as appropriate. This method is a purely VCL-level thing that allows a parent control to force aligned children to be within a bounds less than the actual client area — of the standard controls, it’s used by TGroupBox to make sure a top aligned child (for example) will be below the group box caption rather than over it.

Given this, my demo simply overrides AdjustClientRect as thus:

procedure TfrmMain.AdjustClientRect(var Rect: TRect);
begin
  inherited;
  if FUseCustomFrame then Inc(Rect.Top, GlassFrame.Top);
end;

One thing the demo more unfortunately demonstrates too, though, is the issue I blogged about recently: unless you mark the EXE to require the Vista sub-system or later, the custom frame will not work properly with non-sizeable border styles.

Anyhow, if you’re interested, I’ve put the demo up on CodeCentral here.

[Edit, in response to comments: by design, the pre-compiled EXE won’t work on XP or earlier! Read what I wrote here for why. Not by design, I intially hacked away at the precompiled EXE too much. I’ve taken the EXE out of the ZIP for now.]

[Edit 2: check out the comment by Torbins below for a potentially much simpler alternative to taking out the non-client area. That said, I can’t get this to work properly when compiling with D2007 — it causes ‘ghost’ buttons in use, amongst artifacts.]

[Edit 3 (Jan 2011): I finally got round to fixing the demo. There’s also an additional fix for the ghost buttons that appeared on Windows 7 64 bit (these were the same buttons that plagued the alternative solution on all platforms), plus the source to a small console application I wrote to do the patching mentioned above. Download location is as before.]

Setting up a custom title bar on Vista/Windows 7

Back in the day, if you wanted to draw in a form’s title bar for some reason (to, for example, add one or more extra buttons), you would handle the WM_NCPAINT message and draw to a handle got from the GetDCEx function. While you can still do this with recent versions of Windows, it will cause the window frame to lose its ‘glass’ styling and translucent effects, something that is generally not what you want.

How, then, should you go about customising the title bar in the ‘Aero’ world of Vista and Windows 7? In this post and its sequel, I will document my attempts at finding out. One thing I should emphasise at the off is that this has been a matter of trial and error on my part, of playing around really. Moreover, one might well think that custom window frames are a crappy idea in the first place — even I can’t see the point of Google Chrome putting its page tabs inside its title bar rather than below it, for example. Nonetheless, they can have their use, and anyway, solving a Windows API puzzle can be interesting in itself…

The basics

Realistically, the minimum Delphi version you should be using here is 2007, which makes sense given this version was released not long after Vista debuted. While you could struggle along with an older version — hell, Delphi 2 might be considered ‘good enough’ to the extent of having a 32 bit compiler capable of calling the Desktop Window Manager (DWM) API — Delphi 2007 both does some of the work of setting up the glass frame for you, and more importantly, amends aspects of the VCL’s implementation to be more (though by no means totally) glass friendly.

Now if you check out MSDN, you’ll come across an article with the very promising title ‘Custom Window Frame Using DWM’. This is basically a mild edit of an earlier blog post on the Windows shell team’s (now discontinued) blog, so you might think it would be the be all and end all of the matter. Unfortunately it is not though, the elephant in the room being its advice to completely remove your window’s (i.e., your form’s) non-client area (see the section entitled ‘Removing the Standard Frame’). The problem with this is that doing such a thing messes up the position of every child control. While this is OK if you can guarantee your application will only run when the DWM is active, making such a guarantee would be foolish given it only takes a few clicks for the user to disable the thing and return to a non-glassy world.

Nonetheless, the basic principle outlined in the article still holds: namely, that to draw on a glass title bar, you have to (a) extend the client area onto it and (b) extend the glass area by the same amount that you just added to the client area. (In practice, given the way Windows works, you actually do (b) before (a), but I’ll come to that in a moment.) Painting must then be done on a bitmap in a specific format, which then gets blitted to the DWM’s own buffer. Given most GDI functions (and thus, most native Delphi graphics) are not alpha-channel aware, you also have to be a bit careful about what you draw onto the bitmap. Nonetheless, the VCL does a fair bit of the legwork overall, even if there’s still a lot of things to do manually, as we shall now see.

Setting things up

To get going, create a new VCL application, and head for the code editor. There, create a uses clause in the implementation section, and add DwmApi to it. Then, to the form class, add a private integer field called FWndFrameSize, and the following code as a handler for the form’s OnCreate event:

procedure TForm1.FormCreate(Sender: TObject);
var
  R: TRect;
begin
  if DwmCompositionEnabled then
  begin
    SetRectEmpty(R);
    AdjustWindowRectEx(R, GetWindowLong(Handle, GWL_STYLE), False,
      GetWindowLong(Handle, GWL_EXSTYLE));
    FWndFrameSize := R.Right;
    GlassFrame.Top := -R.Top;
    GlassFrame.Enabled := True;
    SetWindowPos(Handle, 0, Left, Top, Width, Height, SWP_FRAMECHANGED);
    DoubleBuffered := True;
  end;
end;

This code first checks to see whether glass is enabled, before extending the glass frame by the size of the title bar. The SetWindowPos call then causes the non-client area to be recalculated, and setting DoubleBuffered to True gets the VCL to do the special buffering I mentioned earlier (in Delphi 2009 or later, it also causes child controls to be double buffered — more on that in a later post however).

Run the application, and you’ll find it produces a form with a fat title bar, since while we’ve increased the glass frame size, we haven’t taken out the non-client area for the standard title bar. To do that, we need to now override the default handling of the WM_NCCALCSIZE message. For this, add the following to the form’s definition:

  protected
    procedure WMNCCalcSize(var Message: TWMNCCalcSize); message WM_NCCALCSIZE;

And then this code to its implementation:

procedure TForm1.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
  if not GlassFrame.Enabled then
    inherited
  else
    with Message.CalcSize_Params.rgrc[0] do
    begin
      Inc(Left, FWndFrameSize);
      Dec(Right, FWndFrameSize);
      Dec(Bottom, FWndFrameSize);
    end;
end;

Basically, the input rectangle here is the new window bounds. By leaving Top alone, we are in effect extending the client area onto where the non-client area would normally be. (An alternative implementation would be to call ‘inherited’ and change Top to be back to what it was before calling the default implementation.)

So, run the application again; this time, the title bar should be restored to its proper size. However, you may now note the following issues:

1. Both the form’s icon and its caption have been lost.
2. The title bar itself does not do anything when you double-click or right-click it, or indeed attempt to drag it.
3. The form’s top border does not allow us to resize the form any more.
4. While the minimise/maximise/close buttons still show, they don’t do anything (you’ve have to press Alt+F4 to exit the application cleanly).
5. Under 64 bit versions of Windows, ‘ghost’ buttons can emerge underneath the real ones — and unlike the real ones, the zombies do actually work! To see this, hover the mouse cursor just below the close button, directly underneath or just right of the X; after a short while, the ‘Close’ tooltip will show. If you then press and hold down the left mouse button, the ghostly appearance of an old-style close button will emerge; let go, and the form will close.

All in all, it’s time to do a bit of fixing.

Fix, fix and fix again

With respect to the real buttons not working, the fix is to call a particular DWM API function when handling the WM_NCHITTEST message. Since the name of this function is the rather generic-sounding DwmDefWindowProc, I would do this by overriding the form’s WndProc method as thus:

procedure TForm1.WndProc(var Message: TMessage);
begin
  if GlassFrame.Enabled and HandleAllocated and DwmDefWindowProc(Handle,
    Message.Msg, Message.WParam, Message.LParam, Message.Result) then Exit;
  inherited;
end;

While that was nice and easy, fixing the other issues is a bit more involved. In the first instance, we need to be able to know where the icon should be, so define a private method called GetSysIconRect as thus:

function TForm1.GetSysIconRect: TRect;
begin
  if not (biSystemMenu in BorderIcons) or not (BorderStyle in [bsSingle, bsSizeable]) then
    SetRectEmpty(Result)
  else
  begin
    Result.Left := 0;
    Result.Right := GetSystemMetrics(SM_CXSMICON);
    Result.Bottom := GetSystemMetrics(SM_CYSMICON);
    if WindowState = wsMaximized then
      Result.Top := GlassFrame.Top - Result.Bottom - 2
    else
      Result.Top := 6; //is the 'right' value for both normal and large fonts on my machine
    Inc(Result.Bottom, Result.Top);
  end;
end;

With this, we can now amend the handling of the WM_NCHITEST message to detect the system icon area as normal. A custom WM_NCHITEST handler is also where we slay the ghost buttons, the method being to correct any claim of the default handler to have found where the minimise/maximise/close buttons should be (this works because the real buttons are all handled by a separate DWM process rather than the form and its underlying window).

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
  ClientPos: TPoint;
  IconRect: TRect;
begin
  inherited;
  if not GlassFrame.Enabled then Exit;
  case Message.Result of
    HTCLIENT: {to be dealt with below};
    HTMINBUTTON, HTMAXBUTTON, HTCLOSE:
    begin
      Message.Result := HTCAPTION; //slay ghost btns when running on Win64
      Exit;
    end;
  else Exit;
  end;
  ClientPos := ScreenToClient(Point(Message.XPos, Message.YPos));
  if ClientPos.Y > GlassFrame.Top then Exit;
  if ControlAtPos(ClientPos, True) <> nil then Exit;
  IconRect := GetSysIconRect;
  if (ClientPos.X < IconRect.Right) and ((WindowState = wsMaximized) or
     ((ClientPos.Y >= IconRect.Top) and (ClientPos.Y < IconRect.Bottom))) then
    Message.Result := HTSYSMENU
  else if ClientPos.Y < FWndFrameSize then
    Message.Result := HTTOP
  else
    Message.Result := HTCAPTION;
end;

This should all be pretty self-explanatory. Perhaps the only line that isn’t is the one with the ControlAtPos call — all that’s for, though, is to make sure we don’t prevent any TGraphicControl descendant placed on the custom title bar from receiving mouse messages.

Anyhow, run the application once more, and you should find the following:

• Double clicking the form’s title bar now correctly toggles its maximised state.
• The top border of the form once more allows us to resize it.
• While it isn’t visible, left-clicking where the icon belongs brings up the system menu. This exhibits the behaviour of the title bar in Windows Explorer under both Vista and Windows 7.

Alas, but two issues remain, along with a third that is now explicit given the maximise button works:

• We still need to actually draw the icon. There’s also the caption to be drawn too.
• Right-clicking the title bar still doesn’t do what it should, which is to bring up the system menu.
• Maximise the form, then minimise it, then un-minimize it. The client area goes all black!

The third issue here is actually the first time the VCL’s default handling of things has got in the way (all the other issues have been standard DWM irritations you would have to face when using any framework). Basically, when trapping the WM_WINDOWPOSCHANGING message, TCustomForm can set a flag that says the glass frame needs to be ‘refreshed’, which in practice means painting the form black in PaintWindow, a virtual protected method inherited from TWinControl (Ord(clBlack) = 0 = completely transparent if an alpha channel is assumed). Presumably because the code doesn’t imagine an extended glass frame will be used only to make up for an extended client area, this flag then ends up getting set when we don’t want it to.

Nonetheless, after a bit of playing around, I found a fix that’s pretty simple — basically, you just need to clip out the client area in an override for PaintWindow:

procedure TForm1.PaintWindow(DC: HDC);
begin 
  with GetClientRect do
    ExcludeClipRect(DC, 0, GlassFrame.Top, Right, Bottom);
  inherited;
end;

Note that if you want to draw outside of the custom title bar area in either an override for the Paint method or a handler for the OnPaint event, you’ll have to now reset the clipping region first.

While we’re about it, we should also ensure the form gets invalidated appropriately when being resized. For this, define both a private method called InvalidateTitleBar and a custom handler for the WM_WINDOWPOSCHANGING message, implementing them like this:

procedure TForm1.InvalidateTitleBar;
var
  R: TRect;
begin
  if not HandleAllocated then Exit;
  R.Left := 0;
  R.Top := 0;
  R.Right := Width;
  R.Bottom := GlassFrame.Top;
  InvalidateRect(Handle, @R, False);
end;

procedure TForm1.WMWindowPosChanging(var Message: TWMWindowPosChanging);
const
  SWP_STATECHANGED = $8000; //see TCustomForm.WMWindowPosChanging in Forms.pas
begin
  if GlassFrame.Enabled then
    if (Message.WindowPos.flags and SWP_STATECHANGED) = SWP_STATECHANGED then
      Invalidate
    else
      InvalidateTitleBar;
  inherited;
end;

Black painting solved, the next thing to be fixed is the missing system menu. For this, first add some custom handling for the WM_NCRBUTTONUP message:

procedure TForm1.WMNCRButtonUp(var Message: TWMNCRButtonUp);
begin
  if not GlassFrame.Enabled or not (biSystemMenu in BorderIcons) then
    inherited
  else
    case Message.HitTest of
      HTCAPTION, HTSYSMENU: ShowSystemMenu(Self, Message);
    else inherited;
    end;
end;

We obviously now need a ShowSystemMenu routine. This turns out to be a bit long-winded given the need to initialise the menu ourselves. Moreover, the actual showing and making effective of the user’s selection requires a bit of hocus pocus, though the following implementation works well for me:

procedure ShowSystemMenu(Form: TForm; const Message: TWMNCRButtonUp);
var
  Cmd: WPARAM;
  Menu: HMENU;

  procedure UpdateItem(ID: UINT; Enable: Boolean; MakeDefaultIfEnabled: Boolean = False);
  const
    Flags: array[Boolean] of UINT = (MF_GRAYED, MF_ENABLED);
  begin
    EnableMenuItem(Menu, ID, MF_BYCOMMAND or Flags[Enable]);
    if MakeDefaultIfEnabled and Enable then
      SetMenuDefaultItem(Menu, ID, MF_BYCOMMAND);
  end;
begin
  Menu := GetSystemMenu(Form.Handle, False);
  if Form.BorderStyle in [bsSingle, bsSizeable, bsToolWindow, bsSizeToolWin] then
  begin
    SetMenuDefaultItem(Menu, UINT(-1), 0);
    UpdateItem(SC_RESTORE, Form.WindowState <> wsNormal, True);
    UpdateItem(SC_MOVE, Form.WindowState <> wsMaximized);
    UpdateItem(SC_SIZE, (Form.WindowState <> wsMaximized) and
      (Form.BorderStyle in [bsSizeable, bsSizeToolWin]));
    UpdateItem(SC_MINIMIZE, (biMinimize in Form.BorderIcons) and
      (Form.BorderStyle in [bsSingle, bsSizeable]));
    UpdateItem(SC_MAXIMIZE, (biMaximize in Form.BorderIcons) and
      (Form.BorderStyle in [bsSingle, bsSizeable]) and
      (Form.WindowState <> wsMaximized), True);
  end;
  if Message.HitTest = HTSYSMENU then
    SetMenuDefaultItem(Menu, SC_CLOSE, MF_BYCOMMAND);
  Cmd := WPARAM(TrackPopupMenu(Menu, TPM_RETURNCMD or
    GetSystemMetrics(SM_MENUDROPALIGNMENT), Message.XCursor,
    Message.YCursor, 0, Form.Handle, nil));
  PostMessage(Form.Handle, WM_SYSCOMMAND, Cmd, 0)
end;

Restoring the icon and caption

In a standard VCL application, a form’s icon as displayed will come either from its Icon property, or if that is empty (as it will be by default), Application.Icon. Given this and the fact we have already calculated where it should be drawn, one might think of handling the form’s OnPaint event as thus:

procedure TForm1.FormPaint(Sender: TObject);
var
  IconHandle: HICON;
begin
  IconHandle := Icon.Handle;
  if IconHandle = 0 then IconHandle := Application.Icon.Handle;
  with GetSysIconRect do
    DrawIconEx(Canvas.Handle, Left, Top, IconHandle,
      Right - Left, Bottom - Top, 0, 0, DI_NORMAL);
end;

Unless you’ve explicitly set a 32 bit icon, however, this won’t work properly due to the alpha channel issue I mentioned in passing near the start. One easy-ish way to get around this, though, is to use a 32 bit image list as an intermediary.

So, drop a TImageList component onto the form; if you are using Delphi 2009 or later, go and set its ColorDepth property to cd32bit. Then, add CommCtrl to a uses clause, and handle the form’s OnPaint event like this:

procedure TForm1.FormPaint(Sender: TObject);
var
  IconHandle: HICON;
  R: TRect;
begin
  if ImageList1.Count = 0 then
  begin
    ImageList1.Width := GetSystemMetrics(SM_CXSMICON);
    ImageList1.Height := GetSystemMetrics(SM_CYSMICON);
    {$IF NOT DECLARED(TColorDepth)}
    ImageList1.Handle := ImageList_Create(ImageList1.Width,
      ImageList1.Height, ILC_COLOR32 or ILC_MASK, 1, 1);
    {$IFEND}
    IconHandle := Icon.Handle;
    if IconHandle = 0 then IconHandle := Application.Icon.Handle;
    ImageList_AddIcon(ImageList1.Handle, IconHandle);
  end;
  R := GetSysIconRect;
  ImageList1.Draw(Canvas, R.Left, R.Top, 0);
end;

If you’re wondering, the $IF is to support Delphi 2007, and the call to ImageList_AddIcon directly is to avoid an entirely unnecessary exception liable to be raised by TImageList.AddIcon.

With the icon done, the last piece in the jigsaw is to reinstate the form’s caption. Now the advice on MSDN is to use the DrawThemeTextEx API function with a ‘glow size’ of 15, so we’ll follow that. Nonetheless, you need to watch out for the fact that if the form is maximised and running on Vista, it (a) shouldn’t have any glow effect and (b) should be drawn white.

Moreover, I’ve found that the correct font to use is not that found from any theming API, but the old-style GetSysColor and SystemParametersInfo functions — basically, even if you manage to figure out valid parameter values for the theming API equivalents, you’ll only be getting back default values that the user may have overridden in the Control Panel.

Putting this all together, I have come up with the following utility function. It’s a bit lengthy partly because it is intended to be properly generic, though much of it is needed even for the simplest case:

{$IF not Declared(UnicodeString)}
type
  UnicodeString = WideString;
{$IFEND}

procedure DrawGlassCaption(Form: TForm; const Text: UnicodeString;
  Color: TColor; var R: TRect; HorzAlignment: TAlignment = taLeftJustify;
  VertAlignment: TTextLayout = tlCenter; ShowAccel: Boolean = False); overload;
const
  BasicFormat = DT_SINGLELINE or DT_END_ELLIPSIS;
  HorzFormat: array[TAlignment] of UINT = (DT_LEFT, DT_RIGHT, DT_CENTER);
  VertFormat: array[TTextLayout] of UINT = (DT_TOP, DT_VCENTER, DT_BOTTOM);
  AccelFormat: array[Boolean] of UINT = (DT_NOPREFIX, 0);
var
  DTTOpts: TDTTOpts;            { This routine doesn't use GetThemeSysFont and          }
  Element: TThemedWindow;       { GetThemeSysColor because they just return theme       }
  IsVistaAndMaximized: Boolean; { defaults that will be overridden by the 'traditional' }
  NCM: TNonClientMetrics;       { settings as and when the latter are set by the user.  }
  ThemeData: HTHEME;

  procedure DoTextOut;
  begin
    with ThemeServices.GetElementDetails(Element) do
      DrawThemeTextEx(ThemeData, Form.Canvas.Handle, Part, State, PWideChar(Text),
        Length(Text), BasicFormat or AccelFormat[ShowAccel] or
        HorzFormat[HorzAlignment] or VertFormat[VertAlignment], @R, DTTOpts);
  end;
begin
  if Color = clNone then Exit;
  IsVistaAndMaximized := (Form.WindowState = wsMaximized) and
    (Win32MajorVersion = 6) and (Win32MinorVersion = 0);
  ThemeData := OpenThemeData(0, 'CompositedWindow::Window');
  Assert(ThemeData <> 0, SysErrorMessage(GetLastError));
  try
    NCM.cbSize := SizeOf(NCM);
    if SystemParametersInfo(SPI_GETNONCLIENTMETRICS, 0, @NCM, 0) then
      if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
        Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfSmCaptionFont)
      else
        Form.Canvas.Font.Handle := CreateFontIndirect(NCM.lfCaptionFont);
    ZeroMemory(@DTTOpts, SizeOf(DTTOpts));
    DTTOpts.dwSize := SizeOf(DTTOpts);
    DTTOpts.dwFlags := DTT_COMPOSITED or DTT_TEXTCOLOR;
    if Color <> clDefault then
      DTTOpts.crText := ColorToRGB(Color)
    else if IsVistaAndMaximized then
      DTTOpts.dwFlags := DTTOpts.dwFlags and not DTT_TEXTCOLOR
    else if Form.Active then
      DTTOpts.crText := GetSysColor(COLOR_CAPTIONTEXT)
    else
      DTTOpts.crText := GetSysColor(COLOR_INACTIVECAPTIONTEXT); 
    if not IsVistaAndMaximized then
    begin
      DTTOpts.dwFlags := DTTOpts.dwFlags or DTT_GLOWSIZE;
      DTTOpts.iGlowSize := 15;
    end;
    if Form.WindowState = wsMaximized then
      if Form.Active then
        Element := twMaxCaptionActive
      else
        Element := twMaxCaptionInactive
    else if Form.BorderStyle in [bsToolWindow, bsSizeToolWin] then
      if Form.Active then
        Element := twSmallCaptionActive
      else
        Element := twSmallCaptionInactive
    else
      if Form.Active then
        Element := twCaptionActive
      else
        Element := twCaptionInactive;
    DoTextOut;
    if IsVistaAndMaximized then DoTextOut;
  finally
    CloseThemeData(ThemeData);
  end;
end;

procedure DrawGlassCaption(Form: TForm; var R: TRect;
  HorzAlignment: TAlignment = taLeftJustify; VertAlignment: TTextLayout = tlCenter;
  ShowAccel: Boolean = False); overload;
begin
  DrawGlassCaption(Form, Form.Caption, clDefault, R,
    HorzAlignment, VertAlignment, ShowAccel);
end;

To get this to compile, you’ll need to add both UxTheme and Themes to a uses clause, together with StdCtrls (the latter for the TTextLayout enumerated type). Just to make things a touch easier, define the following utility function too:

function GetDwmBorderIconsRect(Form: TForm): TRect;
begin
  if DwmGetWindowAttribute(Form.Handle, DWMWA_CAPTION_BUTTON_BOUNDS, @Result,
    SizeOf(Result)) <> S_OK then SetRectEmpty(Result);
end;

This all done, go back to the OnPaint handler we added earlier, and append to it the following code:

  R.Left := R.Right + FWndFrameSize - 3;
  if WindowState = wsMaximized then
    R.Top := FWndFrameSize
  else
    R.Top := 0;
  R.Right := GetDwmBorderIconsRect(Self).Left - FWndFrameSize - 1;
  R.Bottom := GlassFrame.Top;
  DrawGlassCaption(Self, R);
end;

Lastly, invalidate the title bar when the form is either activated or deactivated — we need to do this since the font colour used in non-active title bars is typically different (if only slightly) from that used in active ones:

procedure TForm1.WMActivate(var Message: TWMActivate);
begin
  inherited;
  InvalidateTitleBar;
end;

If you want to be a perfectionist, you can also handle CM_TEXTCHANGED to make sure the custom title bar gets updated when the form’s Caption property is changed:

procedure TForm1.CMTextChanged(var Message: TMessage);
begin
  inherited;
  InvalidateTitleBar;
end;

Run the application again, and you should find this has all produced a reasonable enough result. Admittedly, and despite the advice on MSDN to use it, DrawThemeTextEx doesn’t paint the caption exactly like the standard frame does — if you look closely, you’ll see the latter uses a solid rectangular background ‘glow’ rather than a character-outlining one. Nonetheless, the DrawThemeTextEx approach seems to be what the custom frames of Microsoft applications use — check out (say) Word 2007 or Windows Live Movie Maker to see what I mean.

That said, the whole point of this exercise was not simply to replicate the standard frame as best we could; rather, it was to add things to it. So, back in the form designer, drop a TSpeedButton onto the form, and place it near the top of the client area:

Add a handler for the button’s OnClick handler if you wish, then run the application once more; if things are all well, it should look like this:

Result!

[Note: I amended this article on 30/1/11 to fix a ghost buttons issue when running on Windows 7 64 bit.]