免费小工具

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).

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

Fix, fix and fix again

With respect to the buttons problem, 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 issues (1) to (3) 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 handle the WM_NCHITEST message like this:

procedure TForm1.WMNCHitTest(var Message: TWMNCHitTest);
var
  ClientPos: TPoint;
  IconRect: TRect;
begin
  inherited;
  if (Message.Result <> Windows.HTCLIENT) or not GlassFrame.Enabled then Exit;
  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 (cf. the title bar appearance and behaviour of Windows Explorer).

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!