tntthememgr.pas

Make your Delphi application UNICODE enabled.

{*****************************************************************************}
{                                                                             }
{    Tnt Delphi Unicode Controls                                              }
{      http://www.tntware.com/delphicontrols/unicode/                         }
{        Version: 2.2.2                                                       }
{                                                                             }
{    Copyright (c) 2002-2005, Troy Wolbrink ([e-mail])       }
{                                                                             }
{*****************************************************************************}

unit TntThemeMgr;

{$INCLUDE TntCompilers.inc}

//---------------------------------------------------------------------------------------------
// TTntThemeManager is a TThemeManager descendant that knows about Tnt Unicode controls.
//   Most of the code is a complete copy from the Mike Lischke's original with only a
//     few modifications to enabled Unicode support of Tnt controls.
//---------------------------------------------------------------------------------------------
// The initial developer of ThemeMgr.pas is:
//   Dipl. Ing. Mike Lischke ([e-mail], www.lischke-online.de).
//     http://www.delphi-gems.com/ThemeManager.php
//
// Portions created by Mike Lischke are
// (C) 2001-2002 Mike Lischke. All Rights Reserved.
//---------------------------------------------------------------------------------------------

interface

uses
  Windows, Sysutils, Messages, Classes, Controls, Graphics, Buttons, ComCtrls, ThemeMgr, ThemeSrv;

{TNT-WARN TThemeManager}
type
  TTntThemeManagerHelper = class(TComponent)
  private
    FTntThemeManager: TThemeManager{TNT-ALLOW TThemeManager};
    procedure GroupBox_WM_PAINT(Control: TControl; var Message : TMessage);
    procedure CheckListBox_CN_DRAWITEM(Control: TControl; var Message: TMessage);
    procedure Panel_NewPaint(Control: TControl; DC: HDC);
    procedure Panel_WM_PAINT(Control: TControl; var Message: TMessage);
    procedure Panel_WM_PRINTCLIENT(Control: TControl; var Message: TMessage);
    procedure ToolBar_WM_LBUTTONDOWN(Control: TControl; var Message: TMessage);
    procedure ToolBar_WM_LBUTTONUP(Control: TControl; var Message: TMessage);
    procedure ToolBar_WM_CANCELMODE(Control: TControl; var Message: TMessage);
    procedure BitBtn_CN_DRAWITEM(Control: TControl; var Message: TMessage);
    procedure SpeedButton_WM_PAINT(Control: TControl; var Message: TMessage);
  protected
    procedure DrawBitBtn(Control: TBitBtn{TNT-ALLOW TBitBtn}; var DrawItemStruct: TDrawItemStruct);
    procedure DrawButton(Control: TControl; Button: TThemedButton; DC: HDC; R: TRect; Focused: Boolean);
  public
    constructor Create(AOwner: TThemeManager{TNT-ALLOW TThemeManager}); reintroduce;
    function DoControlMessage(Control: TControl; var Message: TMessage): Boolean;
  end;

  TTntThemeManager = class(TThemeManager{TNT-ALLOW TThemeManager})
  private
    FThemeMgrHelper: TTntThemeManagerHelper;
  protected
    function DoControlMessage(Control: TControl; var Message: TMessage): Boolean; override;
    procedure Loaded; override;
  public
    constructor Create(AOwner: TComponent); override;
  end;

procedure Register;

implementation

uses
  TntClasses, TntControls, StdCtrls, TntStdCtrls, TntButtons, TntCheckLst, ExtCtrls,
  TntExtCtrls, TntGraphics, TntWindows;

procedure Register;
begin
  RegisterComponents('Tnt Additional', [TTntThemeManager]);
end;

var
  GlobalCheckWidth: Integer;
  GlobalCheckHeight: Integer;

procedure GetCheckSize;
begin
  with TBitmap.Create do
  try
    Handle := LoadBitmap(0, PAnsiChar(32759));
    GlobalCheckWidth := Width div 4;
    GlobalCheckHeight := Height div 3;
  finally
    Free;
  end;
end;

{ TTntThemeManagerHelper }

constructor TTntThemeManagerHelper.Create(AOwner: TThemeManager{TNT-ALLOW TThemeManager});
begin
  inherited Create(AOwner);
  FTntThemeManager := AOwner;
end;

function TTntThemeManagerHelper.DoControlMessage(Control: TControl; var Message: TMessage): Boolean;
begin
  Result := False;
  if ThemeServices.ThemesEnabled then begin
    case Message.Msg of
      WM_PAINT:
        if (Control is TTntCustomPanel) then begin
          Result := True;
          Panel_WM_PAINT(Control, Message);
        end else if (Control is TTntCustomGroupBox) then begin
          Result := True;
          GroupBox_WM_PAINT(Control, Message);
        end else if (Control is TTntSpeedButton) then begin
          Result := True;
          SpeedButton_WM_PAINT(Control, Message);
        end;
      CN_DRAWITEM:
        if (Control is TTntCheckListBox) then begin
          Result := True;
          CheckListBox_CN_DRAWITEM(Control, Message);
        end else if (Control is TTntBitBtn) then begin
          Result := True;
          BitBtn_CN_DRAWITEM(Control, Message);
        end;
      WM_PRINTCLIENT:
        if (Control is TTntCustomPanel) then begin
          Result := True;
          Panel_WM_PRINTCLIENT(Control, Message);
        end;
      WM_LBUTTONDOWN:
        if (Control is TToolBar{TNT-ALLOW TToolBar}) then
          ToolBar_WM_LBUTTONDOWN(Control, Message);
      WM_LBUTTONUP:
        if (Control is TToolBar{TNT-ALLOW TToolBar}) then
          ToolBar_WM_LBUTTONUP(Control, Message);
      WM_CANCELMODE:
        if (Control is TToolBar{TNT-ALLOW TToolBar}) then
          ToolBar_WM_CANCELMODE(Control, Message);
    end;
  end;
  if Result then
    Message.Msg := WM_NULL;
end;

// ------- Group Box --------

type
  // Used to access protected properties.
  TGroupBoxCast = class(TTntCustomGroupBox);

procedure TTntThemeManagerHelper.GroupBox_WM_PAINT(Control: TControl; var Message: TMessage);
var
  GroupBoxCast: TGroupBoxCast;

  procedure NewPaint(DC: HDC);
  var
    CaptionRect,
    OuterRect: TRect;
    Size: TSize;
    LastFont: HFONT;
    Box: TThemedButton;
    Details: TThemedElementDetails;
  begin
    with FTntThemeManager, GroupBoxCast  do
    begin
      LastFont := SelectObject(DC, Font.Handle);
      if Caption <> '' then
      begin
        SetTextColor(DC, Graphics.ColorToRGB(Font.Color));
        // Determine size and position of text rectangle.
        // This must be clipped out before painting the frame.
        GetTextExtentPoint32W(DC, PWideChar(Caption), Length(Caption), Size);
        CaptionRect := Rect(0, 0, Size.cx, Size.cy);
        if not UseRightToLeftAlignment then
          OffsetRect(CaptionRect, 8, 0)
        else
          OffsetRect(CaptionRect, Width - 8 - CaptionRect.Right, 0);
      end
      else
        CaptionRect := Rect(0, 0, 0, 0);

      OuterRect := ClientRect;
      OuterRect.Top := (CaptionRect.Bottom - CaptionRect.Top) div 2;
      with CaptionRect do
        ExcludeClipRect(DC, Left, Top, Right, Bottom);
      if Control.Enabled then
        Box := tbGroupBoxNormal
      else
        Box := tbGroupBoxDisabled;
      Details := ThemeServices.GetElementDetails(Box);
      ThemeServices.DrawElement(DC, Details, OuterRect);

      SelectClipRgn(DC, 0);
      if Caption <> '' then
        ThemeServices.DrawText{TNT-ALLOW DrawText}(DC, Details, Caption, CaptionRect, DT_LEFT, 0);
      SelectObject(DC, LastFont);
    end;
  end;

var
  PS: TPaintStruct;
begin
  GroupBoxCast := TGroupBoxCast(Control as TTntCustomGroupBox);
  BeginPaint(GroupBoxCast.Handle, PS);
  NewPaint(PS.hdc);
  GroupBoxCast.PaintControls(PS.hdc, nil);
  EndPaint(GroupBoxCast.Handle, PS);
  Message.Result := 0;
end;

// ------- Check List Box --------

type
  TCheckListBoxCast = class(TTntCheckListBox);

procedure TTntThemeManagerHelper.CheckListBox_CN_DRAWITEM(Control: TControl; var Message: TMessage);
var
  DrawState: TOwnerDrawState;
  ListBox: TCheckListBoxCast;

  procedure DrawCheck(R: TRect; AState: TCheckBoxState; Enabled: Boolean);
  var
    DrawRect: TRect;
    Button: TThemedButton;
    Details: TThemedElementDetails;
  begin
    DrawRect.Left := R.Left + (R.Right - R.Left - GlobalCheckWidth) div 2;
    DrawRect.Top := R.Top + (R.Bottom - R.Top - GlobalCheckWidth) div 2;
    DrawRect.Right := DrawRect.Left + GlobalCheckWidth;
    DrawRect.Bottom := DrawRect.Top + GlobalCheckHeight;
    case AState of
      cbChecked:
        if Enabled then
          Button := tbCheckBoxCheckedNormal
        else
          Button := tbCheckBoxCheckedDisabled;
      cbUnchecked:
        if Enabled then
          Button := tbCheckBoxUncheckedNormal
        else
          Button := tbCheckBoxUncheckedDisabled;
      else // cbGrayed
        if Enabled then
          Button := tbCheckBoxMixedNormal
        else
          Button := tbCheckBoxMixedDisabled;
    end;
    with FTntThemeManager do begin
      Details := ThemeServices.GetElementDetails(Button);
      ThemeServices.DrawElement(ListBox.Canvas.Handle, Details, DrawRect, @DrawRect);
    end;
  end;

  procedure NewDrawItem(Index: Integer; Rect: TRect; DrawState: TOwnerDrawState);
  var
    Flags: Integer;
    Data: WideString;
    R: TRect;
    ACheckWidth: Integer;
    Enable: Boolean;
  begin
    with ListBox do
    begin
      if Assigned(OnDrawItem) and (Style <> lbStandard)then
        OnDrawItem(ListBox, Index, Rect, DrawState)
      else
      begin
        ACheckWidth := GetCheckWidth;
        if Index < Items.Count then
        begin
          R := Rect;
          // Delphi 4 has neither an enabled state nor a header state for items.
          Enable := Enabled and ItemEnabled[Index];
          if not Header[Index] then
          begin
            if not UseRightToLeftAlignment then
            begin
              R.Right := Rect.Left;
              R.Left := R.Right - ACheckWidth;
            end
            else
            begin
              R.Left := Rect.Right;
              R.Right := R.Left + ACheckWidth;
            end;
            DrawCheck(R, State[Index], Enable);
          end
          else
          begin
            Canvas.Font.Color := HeaderColor;
            Canvas.Brush.Color := HeaderBackgroundColor;
          end;
          if not Enable then
            Canvas.Font.Color := clGrayText;
        end;
        Canvas.FillRect(Rect);
        if Index < Count then
        begin
          Flags := DrawTextBiDiModeFlags(DT_SINGLELINE or DT_VCENTER or DT_NOPREFIX);
          if not UseRightToLeftAlignment then
            Inc(Rect.Left, 2)
          else
            Dec(Rect.Right, 2);
          Data := '';
          if (Style in [lbVirtual, lbVirtualOwnerDraw]) then
            Data := DoGetData(Index)
          else
            Data := Items[Index];

          Tnt_DrawTextW(Canvas.Handle, PWideChar(Data), Length(Data), Rect, Flags);
        end;
      end;
    end;
  end;

begin
  ListBox := TCheckListBoxCast(Control);
  if ListBox.Count > 0
  then begin
    with TWMDrawItem(Message).DrawItemStruct^, ListBox do
    begin
      if not Header[itemID] then
        if not UseRightToLeftAlignment then
          rcItem.Left := rcItem.Left + GetCheckWidth
        else
          rcItem.Right := rcItem.Right - GetCheckWidth;
      DrawState := TOwnerDrawState(LongRec(itemState).Lo);
      Canvas.Handle := hDC;
      Canvas.Font := Font;
      Canvas.Brush := Brush;
      if (Integer(itemID) >= 0) and (odSelected in DrawState) then
      begin
        Canvas.Brush.Color := clHighlight;
        Canvas.Font.Color := clHighlightText
      end;
      if Integer(itemID) >= 0 then
        NewDrawItem(itemID, rcItem, DrawState)
      else
        Canvas.FillRect(rcItem);
      if odFocused in DrawState then
        DrawFocusRect(hDC, rcItem);
      Canvas.Handle := 0;
    end;
  end;
end;

// ------- Panel --------

type
  // Used to access protected properties.
  TPanelCast = class(TTntCustomPanel);

procedure TTntThemeManagerHelper.Panel_NewPaint(Control: TControl; DC: HDC);
const
  Alignments: array[TAlignment] of Longint = (DT_LEFT, DT_RIGHT, DT_CENTER);
var
  TopColor, BottomColor: TColor;

  procedure AdjustColors(Bevel: TPanelBevel);
  begin
    TopColor := clBtnHighlight;
    if Bevel = bvLowered then
      TopColor := clBtnShadow;
    BottomColor := clBtnShadow;
    if Bevel = bvLowered then
      BottomColor := clBtnHighlight;
  end;

var
  Rect: TRect;
  FontHeight: Integer;
  Flags: Longint;
  Details: TThemedElementDetails;
  OldFont: HFONT;
begin
  with TPanelCast(Control as TTntCustomPanel) do
  begin
    Canvas.Handle := DC;
    try
      Canvas.Font := Font;
      Rect := GetClientRect;
      if BevelOuter <> bvNone then
      begin
        AdjustColors(BevelOuter);
        Frame3D(Canvas, Rect, TopColor, BottomColor, BevelWidth);
      end;