Private Declare Function SendMessage Lib  "User32"  _
Alias  "SendMessageA"  (ByVal hwnd As Long, _
  ByVal wMsg As Long, ByVal wParam As Long, _
  lParam As Long) As Long
  Private Declare Function SetProp Lib  "User32"  Alias  "SetPropA"  _
(ByVal hwnd As Long, lpString As String, hData As Long) As Boolean


Sub ChangeCaption()
  Dim intWindowHandle As Long
  intWindowHandle = Screen.ActiveForm.hwnd

' Так как-то
  Call SendMessage(intWindowHandle, TVM_SETBKCOLOR, 0, ByVal RGB(255, 0, 0))

'Или так
Call SetProp(intWindowHandle,  "PROP_ICON" ,  1 )
End Sub

{$F+,X+}
unit WordCap;
{**********************************************************************}
{** WordCap  - provides a gradient filled caption bar, with Italic   **}
{**            text, in the style of MSOffice for Win95.             **}
{**  ---------------------------------------------------------------- **}
 
{** Author   - Warren F. Young.                                      **}
{**            Portions of code were taken from Brad D. Stowers.     **}
{**            Brad acknowledged assistance from Michiel Ouwehand of **}
{**            Epic MegaGames.                                       **}
{**  ---------------------------------------------------------------- **}
 
{** Brief    - Version  1 . 00   ( 23 /July/ 1996 ). Initial release (WWW).  **}
{** History  - Version  1 . 10   ( 1 /October/ 1996 ).                       **}
{**              re-Released on WWW.  First official release.        **}
{**          - Version  1 . 20   ( 17 /December/ 1996 ).                     **}
{**              Fixed some drawing problems.                        **}
{**          - Version  1 . 30   ( 24 /January/ 1997 )                       **}
{**              Improved drawing routines further (including MDI).  **}
{**              Sent to Delphi SuperPage and Torry's Delphi Pages.  **}
{**          - Version 1.33  (28/February/1997)                      **}
{**              Added Freeze/UnFreeze routines to simplify updating **}
{**              the caption without flickering - useful for MDI     **}
{**              apps which must handle this themselves.             **}
{** ---------------------------------------------------------------- **}
{** Copyright- йcopyright 1996, 1997 by Warren F. Young.             **}
{**            Free to use and redistribute, but my name must        **}
{**            appear somewhere in the source code.  No warranty     **}
{**            is given by the author, expressed or implied.         **}
{** ---------------------------------------------------------------- **}
{** Note about MDI Applications                                      **}
{**            MDI Applications will have a drawing problem with     **}
{**            this caption component which occurs when a new child  **}
{**            is created, and that child is maximized.  To work     **}
{**            around this problem, see the file MDI_Apps.txt for    **}
{**            some code to add to the Child window creation routine.**}
{**            (Yes I know it's a nuisance - if you know a better    **}
{**            solution then please e-mail me).                      **}
{**  ---------------------------------------------------------------- **}
 
{** Known Limitations                                                **}
{**          - In D2 (Win95), when a form is maximized and restored, **}
{**            it zooms, and the caption draws non-shaded.           **}
{**          - The  16 -bit version flickers on redraw.  In Win3.x     **}
{**            this is unavoidable.  In Win95 (D1) it may be         **}
{**            possible to fix it by calling some  32 -bit functions.  **}
{**********************************************************************}

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics,
  Forms, Dialogs,
  {$ifndef win32} Call32NT, {$endif}
  DsgnIntf;

const
  FWordSpacing =  3 ;
type
  TFontKind = (fkCustom, fkSystem, fkSystemI, fkSystemB, fkSystemBI, fkAutoHeight);

  TMSOfficeCaption = class;

  TCompanyText = class(TPersistent)
  private
    { Private declarations }
    FCaption  : String;
    FColorActive  : TColor;
    FColorInactive: TColor;
    FFont     : TFont;
    FFontKind : TFontKind;
    FOwner    : TMSOfficeCaption;
    FVisible  : Boolean;
    function StoreFont : Boolean;
  protected
    { Protected declarations }
    procedure SetColorActive(Value: TColor);
    procedure SetColorInactive(Value: TColor);
    procedure SetCaption(Value: String); virtual;
    procedure SetFont(Value: TFont);
    procedure SetFontKind(Value: TFontKind);
    procedure SetVisible(Value: Boolean);
    procedure SetFontKind_NoRedraw(Value: TFontKind);
  public
    { Public declarations }
    constructor Create(AOwner: TMSOfficeCaption);  virtual;
    destructor  Destroy; override;
  published
    { Published declarations }
    property Caption : String read FCaption write SetCaption stored true;
    property ColorActive : TColor read FColorActive write SetColorActive default clCaptionText;
    property ColorInactive : TColor read FColorInactive write SetColorInactive default clInactiveCaptionText;
    property Font : TFont read FFont write SetFont stored StoreFont;
    property FontKind : TFontKind read FFontKind write SetFontKind;
    property Visible : Boolean read FVisible write SetVisible;
  end;  { TCompanyText }

  TAppNameText = class(TCompanyText)
  end;  { same as TCompanyText, just show differently in object inspector }

  TCaptionText = class(TCompanyText)
  protected
    function  GetCaption: String; virtual;
    procedure SetCaption(Value: String); override;
  published
    { Published declarations }
    property Caption : String read GetCaption write SetCaption;
  end;

  TGradEnabled = (geAlways, geNever, geWhenActive);
  TCaptionStyle = (csWin3, csWin95);
  TFreezer = record
    OldWindowRgn : HRgn;
    RgnIsNull : Boolean;
  end;

  TMSOfficeCaption = class(TComponent)
  private
    { Private declarations }
    FAppNameText  : TAppNameText;
    FCaptionText  : TCaptionText;
    FCompanyText  : TCompanyText;
    FCaptionStyle : TCaptionStyle;
    FColor        : TColor;
    FEnabled      : TGradEnabled;
    FNumColors    : integer;
    FSystemFont   : TFont;
    MyOwner       : TForm;
    MyOwnerHandle : THandle;
    FWindowActive : Boolean;
    FActiveDefined: Boolean;
    procedure ExcludeBtnRgn (var R: TRect);
    function  GetNaturalCaptionStyle : TCaptionStyle;
    procedure GetSystemFont(F : TFont);
    function  GetTextRect: TRect;
    function  GetTitleBarRect: TRect;
    procedure GradientFill(DC: HDC; FBeginColor, FEndColor: TColor; R: TRect);
    function  MeasureText(DC: HDC; R: TRect; FText: TCompanyText): integer;
    procedure PaintMenuIcon(DC: HDC; var R: TRect; Back:TColor);
    procedure PaintCaptionText(DC: HDC; var R: TRect; FText: TCompanyText; Active: Boolean);
    {$ifdef win32}
    procedure Perform_NCPaint(var AMsg: TMessage);
    procedure Perform_NCActivate(var AMsg: TMessage);
    {$endif}
    procedure SetAutoFontHeight(F: TFont);
    procedure SolidFill(DC: HDC; FColor: TColor; R: TRect);
    {$ifndef win32}
    function  TrimCaptionText(Var S: String; DC:HDC; TextRect: TRect) : Boolean;
    {$endif}
    function  WindowIsActive: Boolean;
  protected
    { Protected declarations }
    OldWndProc : TFarProc;
    NewWndProc : Pointer;
    procedure SetColor(C: TColor);
    procedure SetEnabled(Val: TGradEnabled);
    procedure SetNumColors(Val: integer);
    procedure HookWin;
    procedure UnhookWin;
  public
    { Public declarations }
    procedure   HookWndProc(var AMsg: TMessage);
    constructor Create(AOwner: TComponent);  override;
    destructor  Destroy; override;
    {$ifdef win32}
    function    GetWindowRgn_NoCaption: HRgn;
    function    Freeze: TFreezer;
    procedure   UnFreeze(F: TFreezer);
    {$endif}
    procedure   UpdateCaption;
    function    DrawMSOfficeCaption(fActive : boolean) : TRect;
  published
    { Published declarations }
    property AppNameText : TAppNameText read FAppNameText write FAppNameText;
    property CaptionText : TCaptionText read FCaptionText write FCaptionText;
    property CompanyText : TCompanyText read FCompanyText write FCompanyText;
    property Color : TColor read FColor write SetColor default clBlack;
    property Enabled : TGradEnabled read FEnabled write SetEnabled default geAlways;
    property NumColors : integer read FNumColors write SetNumColors default  64 ;
  end;

procedure Register;

implementation

{$ifndef win32}
const SPI_GETNONCLIENTMETRICS =  41 ;
      SM_CXSMICON =  49 ;
      SM_CYSMICON =  50 ;
type
  TOS_Bits = (os16bit, os32bit);
  TW32LogFont = record
   lfHeight: longint;
   lfWidth: longint;
   lfEscapement: longint;
   lfOrientation: longint;
   lfWeight: longint;
   lfItalic: Byte;
   lfUnderline: Byte;
   lfStrikeOut: Byte;
   lfCharSet: Byte;
   lfOutPrecision: Byte;
   lfClipPrecision: Byte;
   lfQuality: Byte;
   lfPitchAndFamily: Byte;
   lfFaceName: array[ 0 ..lf_FaceSize -  1 ] of Char;
   end;

  TNONCLIENTMETRICS = record
    cbSize: longint;
    iBorderWidth: longint;
    iScrollWidth: longint;
    iScrollHeight: longint;
    iCaptionWidth: longint;
    iCaptionHeight: longint;
    lfCaptionFont: TW32LogFont;
    iSmCaptionWidth: longint;
    iSmCaptionHeight: longint;
    lfSmCaptionFont: TW32LogFont;
    iMenuWidth: longint;
    iMenuHeight: longint;
    lfMenuFont: TW32LogFont;
    lfStatusFont: TW32LogFont;
    lfMessageFont: TW32LogFont;
  end;

  TOSVERSIONINFO = record
    dwOSVersionInfoSize: longint;
    dwMajorVersion: longint;
    dwMinorVersion: longint;
    dwBuildNumber: longint;
    dwPlatformId: longint;
    szCSDVersion: array[ 1 .. 128 ] of char;
    end;
  TW32Rect = record
    left, top, right, bottom: longint;
    end;

var
  FOS_Bits : TOS_Bits;
  W32IconRoutinesAvailable : Boolean;
  W32SystemParametersInfo:
    function(uiAction: longint; uiParam:longint; pvParam:TNonClientMetrics; fWinIni:longint; id:longint):longint;
  W32GetSystemMetrics:
    function(index: longint; id:longint):longint;
  W32GetVersionEx:
    function(pvParam:TOSVersionInfo; id:longint):longint;
  CopyImage:
    function(HImage, uType, cX, cY, flags :longint; id:longint):longint;
  DrawIconEx:
    function(HDC, left, top, HIcon, Width, Height, frame, FlickFreeBrush, Flags: longint; id:longint):longint;
  id_W32SystemParametersInfo : Longint;
  id_W32GetSystemMetrics : Longint;
  id_W32GetVersionEx : Longint;
  id_W32CopyImage : Longint;
  id_W32DrawIconEx : Longint;
{$endif}

constructor TCompanyText.Create(AOwner: TMSOfficeCaption);
begin
  inherited Create;
  FOwner := AOwner;
  FColorActive := (clCaptionText);
  FColorInactive := (clInactiveCaptionText);
  FFont := TFont.Create;
  FFontKind := fkSystem;
  FFont.Assign(FOwner.FSystemFont);
  FVisible := true;
  FCaption := '';
end;

destructor TCompanyText.Destroy;
begin
  FFont.Free;
  inherited destroy;
end;

procedure TCompanyText.SetColorActive(Value: TColor);
begin
  FColorActive := value;
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;  { TCompanyText.SetColorActive }

procedure TCompanyText.SetColorInactive(Value: TColor);
begin
  FColorInactive := value;
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;  { TCompanyText.SetColorInactive }

procedure TCompanyText.SetCaption(Value: String);
begin
  FCaption := Value;
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;  { TCompanyText.SetCaption }

procedure TCompanyText.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
  If FFontKind = fkAutoHeight
    then FOwner.SetAutoFontHeight(FFont)
    else FFontKind := fkCustom;
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;  { TCompanyText.SetFont }

function TCompanyText.Storefont : Boolean;
begin
  result := not (FFontKind in [fkSystem, fkSystemB, fkSystemBI, fkSystemI]);
end; { StoreFont }

procedure TCompanyText.SetFontKind(Value: TFontKind);
begin
  SetFontKind_noRedraw(Value);
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;

procedure TCompanyText.SetFontKind_NoRedraw(Value: TFontKind);
begin
  FFontKind := Value;
  case FFontKind of
    fkCustom: { do nothing special };
    fkSystem: FFont.Assign(FOwner.FSystemFont);
    fkSystemI{Italics}: begin
            FFont.Assign(FOwner.FSystemFont);
            FFont.Style := FFont.Style + [fsItalic];
            end;
    fkSystemB{Bold}: begin
            FFont.Assign(FOwner.FSystemFont);
            FFont.Style := FFont.Style + [fsBold];
            end;
    fkSystemBI: begin
            FFont.Assign(FOwner.FSystemFont);
            FFont.Style := FFont.Style + [fsItalic, fsBold];
            end;
    fkAutoHeight: FOwner.SetAutoFontHeight(FFont);
  end;  { case }
end;   { TCompanyText.SetFontKind_noRedraw }

procedure TCompanyText.SetVisible(Value: Boolean);
begin
  FVisible := Value;
  if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;   { TCompanyText.SetVisible }

{ ------------------------------------------------------------------------------}
 
{  TCaptionText Component                                                      }
{ ------------------------------------------------------------------------------}
 
function TCaptionText.GetCaption: String;
begin
  if FOwner.MyOwner <> nil
    then result := FOwner.MyOwner.Caption
    else result := '';
end; { TCaptionText.GetCaption }

procedure TCaptionText.SetCaption(Value: String);
var
  FFreezer : TFreezer;
begin
  if FOwner.MyOwner = nil then exit;
  {$ifdef win32}  FFreezer := FOwner.Freeze;  {$endif}
  if FOwner.MyOwner <> nil then FOwner.MyOwner.Caption := Value;
  {$ifdef win32}  FOwner.UnFreeze(FFreezer);  {$endif}
  FCaption := Value; { store it for painting }
  if csdesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;  { TCaptionText.SetCaption }

{ ------------------------------------------------------------------------------}
 
{  TMSOfficeCaption  Component                                                 }
{ ------------------------------------------------------------------------------}
 
constructor TMSOfficeCaption.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  with AOwner as TForm do MyOwner := TForm(AOwner);  { My pointer to my owner form }
  MyOwnerHandle := MyOwner.Handle;
  FWindowActive := true;  { assumption }
  FActiveDefined := false;
  FCaptionStyle := GetNaturalCaptionStyle;
  FSystemFont := TFont.Create;
  try
    GetSystemFont(FSystemFont);
  except
    {$ifdef win32} On EAccessViolation do begin
    {$else} On EGPFault do begin
    {$endif}
      FSystemFont.Free;
      FSystemFont := nil;
      raise;
    end;
  end;  { try except }
  FAppNameText := TAppNameText.Create(self);
  FCaptionText := TCaptionText.Create(self);
  FCompanyText := TCompanyText.Create(self);
  FColor := clBlack;
  FEnabled := geAlways;
  FNumColors  :=  64 ;
  Hookwin; 
  if csdesigning in ComponentState then
  begin
    { Set default fonts unless stored user settings are being loaded }
    FCompanyText.FCaption := 'Warren''s';
    FAppNameText.FCaption := 'Program -';
    FCaptionText.SetFontKind_noRedraw(fkSystem);
    FAppNameText.SetFontkind_noRedraw(fkSystemB);  { system + bold }
    FCompanyText.SetFontkind_noRedraw(fkSystemBI); { system + bold + italic }
    DrawMSOfficeCaption(WindowIsActive);   { do the first-time draw }
  end;
end;  { TMSOfficeCaption.Create }

destructor TMSOfficeCaption.Destroy;
begin
  UnHookWin;
  FAppNameText.Free;
  FCaptionText.Free;
  FCompanyText.Free;
  FSystemFont.Free;
  { update caption if the parent form is not being destroyed }
  If not (csDestroying in MyOwner.ComponentState) then UpdateCaption;
  inherited destroy;  {Call default processing.}
end;  { TMSOfficeCaption.Destroy }

procedure TMSOfficeCaption.HookWin;
begin
  OldWndProc := TFarProc(GetWindowLong(MyOwnerHandle, GWL_WNDPROC));
  NewWndProc := MakeObjectInstance(HookWndProc);
  SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(NewWndProc));
end;  { HookWin }

procedure TMSOfficeCaption.UnhookWin;
begin
  SetWindowLong(MyOwnerHandle, GWL_WNDPROC, LongInt(OldWndProc));
  if assigned(NewWndProc) then FreeObjectInstance(NewWndProc);
  NewWndProc := nil;
end;  { UnHookWin }

function TMSOfficeCaption.WindowIsActive: Boolean;
begin
  If FActiveDefined then begin Result := FWindowActive; exit; end;
  Result := (MyOwnerHandle = GetActiveWindow);
  If (MyOwner.FormStyle = fsMDIChild)
    then if Application <> nil
    then if Application.Mainform <> nil
    then if MyOwner = Application.Mainform.ActiveMDIChild
    then if Application.Mainform.HandleAllocated
    then if Application.Mainform.Handle = GetActiveWindow
      then result := true;
end;  { WindowIsActive }

{$ifdef win32}
function TMSOfficeCaption.GetWindowRgn_NoCaption: HRgn;
var
  GradRgn,    { The gradient region - that we draw ourselves }
  TempRgn   : HRgn;
  RgnIsNull : Boolean;
  temp      : longint;
  R         : TRect;
begin
  GradRgn := CreateRectRgnIndirect(GetTextRect);
  GetWindowRect(MyOwnerHandle, R);
  OffsetRect(R, -R.left, -R.top);
  TempRgn := CreateRectRgn( 0 ,  0 , MyOwner.Width, MyOwner.Height);
  Result  := CreateRectRgnIndirect(R);
  temp    := longint(GetWindowRgn(MyOwnerHandle, TempRgn));
  RgnIsNull := ((temp = error) or (temp = NullRegion));
  if not RgnIsNull then GetWindowRgn(MyOwnerHandle, Result);
  if (CombineRgn(TempRgn, Result, GradRgn, RGN_DIFF) <> error)
    then CombineRgn(Result, TempRgn, TempRgn, RGN_COPY);
  DeleteObject(TempRgn);
  DeleteObject(GradRgn);
end;  { GetWindowRgn_NoCaption }
{$endif}

{$ifdef win32}
procedure TMSOfficeCaption.Perform_NCPaint(var AMsg: TMessage);
var
  R, WR : TRect;
  MyRgn : HRgn;
  DC : HDC;
begin
  R := DrawMSOfficeCaption(WindowIsActive);
  DC := GetWindowDC(MyOwnerHandle);
  GetWindowRect(MyOwnerHandle, WR);
  MyRgn := CreateRectRgnIndirect(WR);
  try
    if SelectClipRgn(DC, AMsg.wParam) = ERROR
      then SelectClipRgn(DC, MyRgn);
    OffsetClipRgn(DC, -WR.Left, -WR.Top);
    ExcludeClipRect(DC, R.Left, R.Top, R.Right, R.Bottom);
    OffsetClipRgn(DC, WR.Left, WR.Top);
    GetClipRgn(DC, MyRgn);
    AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle, AMsg.Msg, MyRgn, Amsg.lParam);
  finally
    DeleteObject(MyRgn);
    ReleaseDC(MyOwnerHandle, DC);
  end;
end;  { perform_NCPaint for win32 }

procedure TMSOfficeCaption.Perform_NCActivate(var AMsg: TMessage);
var
  R : TRect;
  FFreezer : TFreezer;
begin
  R := DrawMSOfficeCaption(TWMNCActivate(AMsg).Active);
  FWindowActive := TWMNCActivate(AMsg).Active;
  FActiveDefined := true;
  FFreezer := Freeze;
  AMsg.Result := CallWindowProc(OldWndProc, MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam);
  UnFreeze(FFreezer);
  AMsg.wParam :=  1 ;   { Tell windows that we have handled the message }
end;  { perform_NCActivate for win32 }
{$endif}

{$ifdef win32}
function TMSOfficeCaption.Freeze: TFreezer;
var
  OldWinRgn: HRgn;  { The value initially held as the window's region }
  temp : longint;
begin
  OldWinRgn  := CreateRectRgn(0, 0, MyOwner.Width, MyOwner.Height);
  temp  := longint(GetWindowRgn(MyOwnerHandle, OldWinRgn));
  Result.RgnIsNull := ((temp = error) or (temp = NullRegion));
  Result.OldWindowRgn := OldwinRgn;
  SetWindowRgn(MyOwnerHandle, GetWindowRgn_NoCaption, false);
end;  { Freeze for win32 }

procedure TMSOfficeCaption.UnFreeze(F: TFreezer);
begin
  if F.RgnIsNull
  then begin
    SetWindowRgn(MyOwnerHandle, 0, false);
    DeleteObject(F.OldWindowRgn);
  end else
    SetWindowRgn(MyOwnerHandle, F.OldWindowRgn, false);
end;  { UnFreeze for win32 }
{$endif}

procedure TMSOfficeCaption.HookWndProc(var AMsg: TMessage);
begin
  {$ifdef win32}
  if AMsg.Msg = WM_NCPAINT then
    begin Perform_NCPaint(AMsg); exit; end; { NCPaint is handled for win32 }
  if AMsg.Msg = WM_NCACTIVATE then
    begin Perform_NCActivate(AMsg); exit; end; { NCActivate is handled for win32 }
  {$endif}
  { now handle all other calls }
  AMsg.Result := CallWindowProc(OldWndProc,MyOwnerHandle, AMsg.Msg, AMsg.wParam, AMsg.lParam);
  {$ifndef win32}
  if AMsg.Msg = WM_NCPAINT then DrawMSOfficeCaption(WindowIsActive);
  if AMsg.Msg = WM_NCACTIVATE then DrawMSOfficeCaption(TWMNCActivate(AMsg).Active);
  if AMsg.Msg = WM_NCACTIVATE then
  begin
    FWindowActive := TWMNCActivate(AMsg).Active;
    FActiveDefined := true;
  end;
  {$endif}
  {$ifdef win32}
  if ((AMsg.Msg = WM_DISPLAYCHANGE)  or
      (AMsg.Msg = WM_SysColorChange) or
      (AMsg.Msg = WM_WININICHANGE) or
      (AMsg.Msg = WM_SETTINGCHANGE)) then
  {$else}
  if AMsg.Msg = WM_WININICHANGE then
  {$endIf}
  begin
    GetSystemFont(FSystemFont);  { update systemfont }
    FAppNameText.SetFontkind_noRedraw(FAppNameText.FFontkind);
    FCaptionText.SetFontKind_noRedraw(FCaptionText.FFontKind);
    FCompanyText.SetFontkind_noRedraw(FCompanyText.FFontkind);
    UpdateCaption;  {force a NC region redraw};
  end;
end;  { HookWndProc }

procedure TMSOfficeCaption.UpdateCaption;
begin
  SetWindowPos( MyOwnerHandle, 0, 0, 0, 0, 0,
                SWP_FRAMECHANGED or SWP_DRAWFRAME or
                SWP_NOZORDER or SWP_NOMOVE or SWP_NOSIZE);
end;  { UpdateCaption }

procedure TMSOfficeCaption.GetSystemFont(F : TFont);
var
  FNONCLIENTMETRICS : TNONCLIENTMETRICS;
begin
  F.Handle := GetStockObject(SYSTEM_FONT);
  {$ifndef win32} If (FOS_Bits = os16Bit) then exit; {$endif}
  { if OS is 32bit, get font by calling Win32 API routine }
  FNONCLIENTMETRICS.cbSize := Sizeof(TNONCLIENTMETRICS);
  {$ifdef win32}
  if boolean(SystemParametersInfo(    SPI_GETNONCLIENTMETRICS, 0,
                                      @FNONCLIENTMETRICS, 0))
  {$else}
  if boolean(w32SystemParametersInfo( SPI_GETNONCLIENTMETRICS, 0,
                                      FNONCLIENTMETRICS, 0,
                                      id_w32SystemParametersInfo))
  {$endif}
  then begin
    { work now with FNonClientMetrics.lfCaptionFont }
    F.Name := FNonClientMetrics.lfCaptionFont.lfFacename;
    if FNonClientMetrics.lfCaptionFont.lfHeight > 0
      then F.Size := FNonClientMetrics.lfCaptionFont.lfHeight
      else F.Height := FNonClientMetrics.lfCaptionFont.lfHeight;
    F.Style := [];
    if FNonClientMetrics.lfCaptionFont.lfItalic <> 0
      then F.Style := F.Style + [fsItalic];
    if FNonClientMetrics.lfCaptionFont.lfWeight > FW_MEDIUM
      then F.Style := F.Style + [fsBold];
    F.Pitch := fpDefault;
  end;
end;  { procedure TMSOfficeCaption.GetSystemFont }

function TMSOfficeCaption.GetNaturalCaptionStyle : TCaptionStyle;
{$ifndef win32}
const
  VER_PLATFORM_WIN32s = 0;
  VER_PLATFORM_WIN32_WINDOWS = 1;
  VER_PLATFORM_WIN32_NT = 2;
{$endif}
var win32Ver : TOSVersionInfo;
begin
  result := csWin3;  { assumption }
  {$ifndef win32}
    if FOS_Bits = os16bit then
    begin  { the 16 bit OS version }
      If LoWord(GetVersion) >= $5F03 then result := csWin95; { win95 }
      exit;
    end; { done the 16-bit OS version }
  {$endif}
  { now do the 32 bit OS version }
  Win32Ver.dwOSVersionInfoSize := sizeof(TOSVersionInfo);
  {$ifdef win32} If boolean(GetVersionEx(Win32Ver)) then
  {$else} If boolean(W32GetVersionEx(Win32Ver, id_W32GetVersionEx)) then
  {$endif}
    Case Win32Ver.dwPlatformID of
      VER_PLATFORM_WIN32s : result := csWin3;{ win32s on Win3.x }
      VER_PLATFORM_WIN32_WINDOWS : result := csWin95;{ win95 }
      VER_PLATFORM_WIN32_NT : {winNT}
        if Win32Ver.dwMajorVersion >= 4 then result := csWin95 else result := csWin3;
    else result := csWin95; { assumption for future OS's }
    end;  { case }
end;  { TMSOfficeCaption.GetNaturalCaptionStyle }

function TMSOfficeCaption.GetTitleBarRect: TRect;
var BS : TFormBorderStyle;
begin
  BS:= MyOwner.BorderStyle;
  if csDesigning in ComponentState then BS:= bsSizeable;
  { if we have no border style, then just set the rectangle empty. }
  if BS = bsNone then begin SetRectEmpty(Result); exit; end;

  GetWindowRect(MyOwnerHandle, Result);
  { Convert rect from screen (absolute) to client ( 0  based) coordinates. }
  OffsetRect(Result, -Result.Left, -Result.Top);
  { Shrink rectangle to allow for window border.  We let Windows paint the border. }
  {$ifdef win32}
  { this catches drawing MDI minimised windows caption bars in Win95 }
  if ((GetWindowLong(MyOwnerHandle, GWL_STYLE) and $ 20000000 ) <>  0 )
    then InflateRect(Result, -GetSystemMetrics(SM_CXFIXEDFRAME),
                             -GetSystemMetrics(SM_CYFIXEDFRAME))
  else {$else}
  { this catches drawing MDI minimised windows caption bars in Win95 }
  if ((GetWindowLong(MyOwnerHandle, GWL_STYLE) and $ 20000000 ) <>  0 )
    then InflateRect(Result, -GetSystemMetrics(SM_CYBORDER)-GetSystemMetrics(SM_CXDLGFRAME),
                             -GetSystemMetrics(SM_CYBORDER)-GetSystemMetrics(SM_CYDLGFRAME))
  else {$endif}
  case BS of
    {$ifdef win32} bsToolWindow, bsSingle, bsDialog:
        InflateRect(Result, -GetSystemMetrics(SM_CXFIXEDFRAME),
                            -GetSystemMetrics(SM_CYFIXEDFRAME));
    bsSizeToolWin, bsSizeable:
        InflateRect(Result, -GetSystemMetrics(SM_CXSIZEFRAME),
                            -GetSystemMetrics(SM_CYSIZEFRAME));
    {$else}
    bsDialog:
        InflateRect(Result, -(GetSystemMetrics(SM_CXBORDER)+GetSystemMetrics(SM_CXDLGFRAME)),
                            -(GetSystemMetrics(SM_CYBORDER)+GetSystemMetrics(SM_CYDLGFRAME)) );
    bsSingle:
        InflateRect(Result, -GetSystemMetrics(SM_CXBORDER),
                            -GetSystemMetrics(SM_CYBORDER));
    bsSizeable:
        InflateRect(Result, -GetSystemMetrics(SM_CXFRAME),
                            -GetSystemMetrics(SM_CYFRAME));
    {$endif}
   end;

  { Set the appropriate height of caption bar. }
  {$ifdef win32}
  if BS in [bsToolWindow, bsSizeToolWin] then
    Result.Bottom := Result.Top + GetSystemMetrics(SM_CYSMCAPTION) -  1 
  else {$endif}
    Result.Bottom := Result.Top + GetSystemMetrics(SM_CYCAPTION) -  1 ;
  {$ifndef win32} Result.Bottom := Result.Bottom- 1 ; {$endif}
end;  { GetTitleBarRect }

procedure TMSOfficeCaption.ExcludeBtnRgn (var R: TRect);
var BtnWidth: integer;
    BS : TFormBorderStyle;
begin
  BS:= MyOwner.BorderStyle;
  if csDesigning in ComponentState then BS:= bsSizeable;
  if BS = bsNone then exit;
  BtnWidth := GetSystemMetrics(SM_CXSIZE);
  {$ifdef win32}
  if BS in [bsToolWindow, bsSizeToolWin]
  then begin
      R.Right := R.Right - GetSystemMetrics(SM_CXSMSIZE)-  2 ;  { close icon only }
      exit;
  end;
  {$endif}

  if ((biSystemMenu in MyOwner.BorderIcons) and (FCaptionStyle = csWin95))
    then R.Right := R.Right - BtnWidth -  2 ;  { close icon - this is OS dependant }
  {$ifdef win32}
  if ((BS = bsDialog) and (biHelp in MyOwner.BorderIcons))
    then R.Right := R.Right - BtnWidth -  2 ;  { help icon }
  {$endif}
  if ((BS <> bsDialog) and ((biMinimize in MyOwner.BorderIcons) or (biMaximize in MyOwner.BorderIcons)))
    then R.Right := R.Right -  2 *BtnWidth;  { minimise and maximise icon }
  if ((biSystemMenu in MyOwner.BorderIcons) and (FCaptionStyle = csWin3) and
      (MyOwner.BorderStyle in [bsSingle, bsSizeable]))
    then R.Left := R.Left + BtnWidth;  { let windows do the system icon in win3 style }
end;  { TMSOfficeCaption.ExcludeBtnRgn }

function TMSOfficeCaption.GetTextRect: TRect;
begin
  result := GetTitleBarRect;
  ExcludeBtnRgn(result);

  If result.Right <= result.Left then {error}
    result.Right := result.Left+ 2 ;  { right must be greater than left- otherwise system resources get lost }
end;  { GetTextRect }

{$ifndef win32}
function  TMSOfficeCaption.TrimCaptionText(Var S: String; DC:HDC; TextRect: TRect): Boolean;
{ returns true if the text was altered in any way }
var
  TheWidth : integer;
  textlen : integer;
  temp    : string;
  OldFont: HFont;
  P: ^string;
  T: String;
  R: TRect;
begin
  result := false;  { assume no truncation of text }
  R := Rect( 0 , 0 , 1000 , 100 );
  if FCaptionText.FFont.Handle <>  0 
    then OldFont := SelectObject(DC, FCaptionText.FFont.Handle)
    else OldFont :=  0 ;
  try
    { ------------------------------------------------------------------------}
 
    {Truncate the window caption text, until it will fit into the captionbar.}
    { ------------------------------------------------------------------------}
 
    Temp := S;
    textlen := length(S);
    T := S + # 0 ;
    P := @T[ 1 ];
    DrawText(DC, PChar(P), - 1 , R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);
    TheWidth := R.Right - R.Left;
    { use this to see if the text will fit - if not, remove some chars, add  "..."  and try again }
    { resize or truncate the text to fit in the caption bar}
    while ((TheWidth > (TextRect.right-TextRect.left)) and (TextLen >  1 )) do
    begin
      temp:= Copy(S,  0 , Textlen- 1 );           { truncate                }
      AppendStr(temp, '...');                 { add ... onto text       }
      dec(Textlen);
      T := temp + # 0 ;
      P := @T[ 1 ];
      DrawText(DC, PChar(P), - 1 , R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);
      TheWidth := R.Right - R.Left;
      result := true;
    end;
    S := temp + '   '; { spaces for safety }
  finally
    { Clean up all the drawing objects. }
    if OldFont <>  0  then SelectObject(DC, OldFont);
  end;
end;  { TrimCaptionText }
{$endif}

{ Paint the icon for the system menu.  Based on code from Brad Stowers }
procedure TMSOfficeCaption.PaintMenuIcon(DC: HDC; var R: TRect; Back:TColor);
const
  LR_COPYFROMRESOURCE = $ 4000 ; { Missing from WINDOWS.PAS! }
var
  IconHandle: HIcon;
{$ifndef win32}
const
  IMAGE_ICON =  1 ;
  DI_Normal =  3 ;
{$endif}
begin
  {$ifndef win32}
    If not W32IconRoutinesAvailable then exit;  { a safety catch - shouldn't be needed }
  {$endif}
  Inc(R.Left, 1);
  { Does the form (or application) have an icon assigned to it? }
  if MyOwner.Icon.Handle <> 0
    then IconHandle := MyOwner.Icon.Handle
    else if Application.Icon.Handle <> 0
      then IconHandle := Application.Icon.Handle
      else IconHandle := LoadIcon(0, IDI_APPLICATION);  { system defined application icon. }

  DrawIconEx(DC, R.Left+1, R.Top+1,
             CopyImage(IconHandle,
                       IMAGE_ICON,  { what is it's value??? }
                       {$ifdef win32}
                       GetSystemMetrics(SM_CXSMICON),
                       GetSystemMetrics(SM_CYSMICON),
                       {$else}
                       W32GetSystemMetrics(SM_CXSMICON, id_W32GetSystemMetrics),
                       W32GetSystemMetrics(SM_CYSMICON, id_W32GetSystemMetrics),
                       {$endif}
                       LR_COPYFROMRESOURCE {$ifndef win32},id_W32CopyImage{$endif}),
              0 ,  0 ,  0 ,  0 , DI_NORMAL {$ifndef win32},id_W32DrawIconEx{$endif});
  {$ifdef win32}
    Inc(R.Left, GetSystemMetrics(SM_CXSMICON)+ 1 );
  {$else}
    Inc(R.Left, W32GetSystemMetrics(SM_CXSMICON, id_W32GetSystemMetrics)+ 1 );
  {$endif}
end;  { procedure TMSOfficeCaption.PaintMenuIcon }

{ based on code from Brad Stowers }
procedure TMSOfficeCaption.PaintCaptionText(DC: HDC; var R: TRect; FText: TCompanyText; Active:Boolean);
var
  OldColor: TColorRef;
  OldBkMode: integer;
  OldFont: HFont;
  P: ^string;
  S:String;
  RTemp: TRect;
begin
  Inc(R.Left, FWordSpacing);
  RTemp:= R;
  if Active
    then OldColor := SetTextColor(DC, ColorToRGB(FText.FColorActive))
    else OldColor := SetTextColor(DC, ColorToRGB(FText.FColorInActive));
  OldBkMode := SetBkMode(DC, TRANSPARENT);  { paint text transparently - so gradient can show through }
  { Select in the required font for this text. }
  if FText.FFont.Handle <>  0  then
    OldFont := SelectObject(DC, FText.FFont.Handle)
  else
    OldFont :=  0 ;
  try
    { Draw the text making it left aligned, centered vertically, allowing no line breaks. }
    S := FText.FCaption + # 0 ;
    P := @S[ 1 ];
    DrawText(DC, PChar(P), - 1 , RTemp, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);
    DrawText(DC, PChar(P), - 1 , R, DT_LEFT or DT_VCENTER or DT_SINGLELINE {$ifdef win32} or DT_END_ELLIPSIS {$endif});
    R.Left := RTemp.Right;
  finally
    { Clean up all the drawing objects. }
    if OldFont <>  0  then
      SelectObject(DC, OldFont);
    SetBkMode(DC, OldBkMode);
    SetTextColor(DC, OldColor);
  end;
end;  { procedure TMSOfficeCaption.PaintCaptionText }

function TMSOfficeCaption.MeasureText(DC: HDC; R: TRect; FText: TCompanyText): integer;
var
  OldFont: HFont;
  P: ^string;
  S: String;
begin
  { Select in the required font for this text. }
  if FText.FFont.Handle <>  0 
    then OldFont := SelectObject(DC, FText.FFont.Handle)
    else OldFont :=  0 ;
  try
    { Measure the text making it left aligned, centered vertically, allowing no line breaks. }
    S := FText.FCaption + # 0 ;
    P := @S[ 1 ];
    DrawText(DC, PChar(P), - 1 , R, DT_LEFT or DT_VCENTER or DT_SINGLELINE or DT_CALCRECT);
    Result := R.Right+FWordSpacing - R.Left {- 1 };
  finally
    { Clean up all the drawing objects. }
    if OldFont <>  0  then SelectObject(DC, OldFont);
  end;
end;  { function TMSOfficeCaption.MeasureText }

{******************************************************************************}
{**   DrawMSOfficeCaption - the main routine to draw a shaded caption bar.   **}
{******************************************************************************}
function TMSOfficeCaption.DrawMSOfficeCaption(fActive : boolean) : TRect;
var
  dc,OrigDC : HDC;
  rcText    : TRect;
  rgbBkGrnd : TColor;
  OldBmp    : HBitmap;
  Bmp       : HBitmap;
  TotalTextWidth: longint;
  SpaceForCompanyText : Boolean;
  SpaceForAppNameText : Boolean;
begin {DrawMSOfficeCaption}
  result := Rect( 0 , 0 , 0 , 0 );  { in case somthing fails - e.g. resource allocation }
  If ( (MyOwner.BorderStyle = bsNone) and
       (not (csdesigning in ComponentState)) ) then exit; { no drawing to be done }
  OrigDC := GetWindowDC(MyOwnerHandle);
  if OrigDC =  0  then exit;
  DC := CreateCompatibleDC(OrigDC);
  if DC =  0  then begin ReleaseDC(MyOwnerHandle, OrigDC); exit; end;
  rcText := GetTextRect;
  Bmp := CreateCompatibleBitmap(OrigDC, rcText.Right, rcText.Bottom);
  If Bmp =  0  then begin ReleaseDC(MyOwnerHandle, OrigDC); DeleteDC(DC); exit; end;
  OldBmp := SelectObject(DC, Bmp);
  try
    result := rcText;
    if fActive then rgbBkGrnd := ColorToRGB(clActiveCaption)
               else rgbBkGrnd := ColorToRGB(clInactiveCaption);

    { --------------------------------------------------------------------------}
 
    { Apply Gradient fill (or single color) to all of the Caption Bar area.    }
    { --------------------------------------------------------------------------}
 
    if (((FEnabled = geWhenActive) and fActive) or (FEnabled = geAlways))
      then GradientFill(dc, ColorToRGB(FColor), rgbBkGrnd, rcText)
      else SolidFill(dc, rgbBkGrnd, rcText);

    { --------------------------------------------------------------------------}
 
    { Draw the System Menu Icon.                                               }
    { --------------------------------------------------------------------------}
 
    if (FCaptionStyle = csWin95) then { let windows paint system menu in Win3 style }
    if ( ((biSystemMenu in MyOwner.BorderIcons) and (MyOwner.BorderStyle in [bsSingle, bsSizeable]))
      or (csDesigning in ComponentState) )
      then   if (((FEnabled = geWhenActive) and fActive) or
                  (FEnabled = geAlways))
        then PaintMenuIcon(dc, rcText, FColor)
        else PaintMenuIcon(dc, rcText, rgbBkGrnd);

    { ------------------------------------------------------------------------}
 
    {Determine if there is sufficient space for the CompanyName text and the }
    {CompanyName text and the standard caption text to be all drawn onto the }
    {working Bitmap (i.e. the caption).  If not, is there enough room for    }
    {the AppName text and the standard caption?                              }
    { ------------------------------------------------------------------------}
 
    FCaptionText.FCaption := FCaptionText.Caption; { safety }
    TotalTextWidth := MeasureText(dc,rcText,FCompanyText) * ord(FCompanyText.Visible)
                      + MeasureText(dc,rcText,FAppNameText) * ord(FAppNameText.Visible)
                      + MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);
    SpaceForCompanyText := (TotalTextWidth < (rcText.Right - rcText.Left));
    if SpaceForCompanyText then
      SpaceForAppNameText := true { space for company ==> space for appname }
    else begin
      TotalTextWidth := MeasureText(dc,rcText,FAppNameText) * ord(FAppNameText.Visible)
                        + MeasureText(dc,rcText,FCaptionText) * ord(FCaptionText.Visible);
      SpaceForAppNameText := (TotalTextWidth < (rcText.Right - rcText.Left));
    end;
    if not SpaceForAppNameText
      then TotalTextWidth := MeasureText(dc,rcText,FCaptionText);
    Case FCaptionStyle of
      csWin95: {do nothing, leave things as they are};
      csWin3 : if TotalTextWidth < rcText.right - rcText.left
               then rcText.Left := rcText.left + ((rcText.right - rcText.left - TotalTextWidth) div  2 );
              { centre caption for Win3 style }
    end;  { case of CaptionStyle }

    { ------------------------------------------------------------------------}
 
    { Actually draw the CompanyText, AppNameText, and CaptionText.           }
    { ------------------------------------------------------------------------}
 
    if (SpaceForCompanyText and (FCompanyText.FCaption <> '') and (FCompanyText.FVisible))
      then PaintCaptionText(DC, rcText, FCompanyText, fActive);
    if ((SpaceForAppNameText) and (FAppNameText.FCaption <> '') and (FAppNameText.FVisible))
      then PaintCaptionText(DC, rcText, FAppNameText, fActive);
    {Truncate the window caption text, until it will fit into the caption bar.}
    {$ifndef win32} TrimCaptionText(FCaptionText.FCaption, dc, rcText); {$endif}
    If FCaptionText.FVisible
      then PaintCaptionText(DC, rcText, FCaptionText, fActive);

    { copy from temp DC, onto the actual window Caption }
    BitBlt(OrigDC, Result.Left, Result.Top, Result.Right-Result.Left, Result.Bottom-Result.Top,
           DC, Result.Left, Result.Top, SRCCOPY);
  finally
    {Clean up device context & free memory}{ Release the working bitmap resources }
    Bmp := SelectObject(DC, OldBmp);
    DeleteObject(Bmp);
    DeleteDC(DC);
    ReleaseDC(MyOwnerHandle, OrigDC);
  end;
end;  { DrawMSOfficeCaption }

{ ----------------------------------------------------------------------------}
 
{     Solid fill procedure                                                   }
{ ----------------------------------------------------------------------------}
 
procedure TMSOfficeCaption.SolidFill(DC: HDC; FColor: TColor; R: TRect);
var
  Brush, OldBrush : HBrush;
begin
  Brush := CreateSolidBrush(FColor);
  OldBrush := SelectObject(DC, Brush);
  try
    PatBlt(DC, R.Left, R.Top, R.Right-R.Left, R.Bottom-R.Top, PATCOPY);
  finally
    { Clean up the brush }
    Brush := SelectObject(DC, OldBrush);
    DeleteObject(Brush);
  end;
end;
{ ----------------------------------------------------------------------------}
 
{     Gradient fill procedure                                                }
{ ----------------------------------------------------------------------------}
 
procedure TMSOfficeCaption.GradientFill(DC: HDC; FBeginColor, FEndColor: TColor; R: TRect);
var
  { Set up working variables }
  BeginRGBValue  : array[ 0 .. 2 ] of Byte;    { Begin RGB values }
  RGBDifference  : array[ 0 .. 2 ] of integer; { Difference between begin and end }
                                           { RGB values                       }
  ColorBand : TRect;    { Color band rectangular coordinates }
  I         : Integer;  { Color band index }
  Red       : Byte;     { Color band Red value }
  Green     : Byte;     { Color band Green value }
  Blue      : Byte;     { Color band Blue value }
  Brush, OldBrush     : HBrush;
begin
  { Extract the begin RGB values }
  { Set the Red, Green and Blue colors }
  BeginRGBValue[ 0 ] := GetRValue (ColorToRGB (FBeginColor));
  BeginRGBValue[ 1 ] := GetGValue (ColorToRGB (FBeginColor));
  BeginRGBValue[ 2 ] := GetBValue (ColorToRGB (FBeginColor));
  { Calculate the difference between begin and end RGB values }
  RGBDifference[ 0 ] := GetRValue (ColorToRGB (FEndColor)) - BeginRGBValue[ 0 ];
  RGBDifference[ 1 ] := GetGValue (ColorToRGB (FEndColor)) - BeginRGBValue[ 1 ];
  RGBDifference[ 2 ] := GetBValue (ColorToRGB (FEndColor)) - BeginRGBValue[ 2 ];

  { Calculate the color band's top and bottom coordinates }
  { for Left To Right fills }
  begin
    ColorBand.Top := R.Top;
    ColorBand.Bottom := R.Bottom;
  end;

  { Perform the fill }
  for I := 0 to FNumColors-1 do
  begin  { iterate through the color bands }
    { Calculate the color band's left and right coordinates }
    ColorBand.Left  := R.Left+ MulDiv (I    , R.Right-R.Left, FNumColors);
    ColorBand.Right := R.Left+ MulDiv (I +  1 , R.Right-R.Left, FNumColors);
    { Calculate the color band's color }
    if FNumColors > 1 then
    begin
      Red   := BeginRGBValue[0] + MulDiv (I, RGBDifference[0], FNumColors - 1);
      Green := BeginRGBValue[1] + MulDiv (I, RGBDifference[1], FNumColors - 1);
      Blue  := BeginRGBValue[2] + MulDiv (I, RGBDifference[2], FNumColors - 1);
    end
    else
    { Set to the Begin Color if set to only one color }
    begin
      Red   := BeginRGBValue[0];
      Green := BeginRGBValue[1];
      Blue  := BeginRGBValue[2];
    end;

    { Create a brush with the appropriate color for this band }
    Brush := CreateSolidBrush(RGB(Red,Green,Blue));
    { Select that brush into the temporary DC. }
    OldBrush := SelectObject(DC, Brush);
    try
      { Fill the rectangle using the selected brush -- PatBlt is faster than FillRect }
      PatBlt(DC, ColorBand.Left, ColorBand.Top, ColorBand.Right-ColorBand.Left, ColorBand.Bottom-ColorBand.Top, PATCOPY);
    finally
      { Clean up the brush }
      SelectObject(DC, OldBrush);
      DeleteObject(Brush);
    end;
  end;  { iterate through the color bands }
end;  { GradientFill }

procedure TMSOfficeCaption.SetAutoFontHeight(F : TFont);
var FTextHeight : longint;
    FSysTextHeight : longint;
    FTextMetrics : TTextMetric;
    FSysTextMetrics : TTextMetric;
    WrkBMP   : TBitmap;     { A Bitmap giving us access to the caption bar canvas }
begin
  {------------------------------------------------------------------------}
  { Create the working bitmap and set its width and height.                }
  {------------------------------------------------------------------------}
  WrkBmp := TBitmap.Create;
  try
    WrkBmp.Width := 10;
    WrkBmp.Height := 10;
    WrkBMP.Canvas.Font.Assign(F);
    GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);
    WrkBMP.Canvas.Font.Assign(FSystemFont);
    GetTextMetrics(WrkBmp.Canvas.Handle, FSysTextMetrics);
    FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;
    FSysTextHeight := FSysTextMetrics.tmHeight - FSysTextMetrics.tmInternalLeading;
    F.Height:= F.Height + FTextHeight - FSysTextHeight;
    { test out the new font for accuracy }
    WrkBMP.Canvas.Font.Assign(F);
    GetTextMetrics(WrkBmp.Canvas.Handle, FTextMetrics);
    FTextHeight := FTextMetrics.tmHeight - FTextMetrics.tmInternalLeading;
    If (FTextHeight > FSysTextHeight)
      then F.Height:= F.Height + FTextHeight - FSysTextHeight;
    { this test allows for some fonts that can't be scaled properly - they must show smaller rather than larger }
  finally Wrkbmp.Free;
  end; { try finally }
end;  { SetAutoFontHeight }

procedure TMSOfficeCaption.SetEnabled(Val: TGradEnabled);
begin
  If Val <> FEnabled then
  begin
    FEnabled := Val;
    If csDesigning in ComponentState then UpdateCaption;
  end;
end;  { SetEnabled }

procedure TMSOfficeCaption.SetNumColors(Val: integer);
begin
  If ((Val >  0 ) and (Val <=  256 ))
  then begin
    If Val <> FNumColors then
    begin
      FNumColors := Val;
      If csDesigning in ComponentState then UpdateCaption;
    end;
    exit;
  end;
  if Val <=  0 
  then begin
    If csdesigning in ComponentState then
      MessageDlg('The number of colors must be at least 1', mtError, [mbOK],  0 );
    exit;
  end;
  if Val >  256 
  then begin
    FNumColors :=  256 ;
    If csDesigning in ComponentState then UpdateCaption;
    If csdesigning in ComponentState then
      MessageDlg('The highest number of gradient colors possible is 256', mtError, [mbOK],  0 );
  end;
end;  { SetNumColors }

procedure TMSOfficeCaption.SetColor(C: TColor);
begin
  If FColor <> C
  then begin
    FColor := C;
    If csDesigning in ComponentState then UpdateCaption;
  end;
end;

procedure Register;
begin
  RegisterComponents('Samples', [TMSOfficeCaption]);
  RegisterPropertyEditor(TypeInfo(TCompanyText), nil, '', TClassProperty);
end;

initialization
{$ifndef win32}
  { set up the Win32 API function access for a  16  bit app on a  32  bit OS }
  @W32SystemParametersInfo:=@Call32;
  @W32GetSystemMetrics:=@Call32;
  @W32GetVersionEx:=@Call32;
  @CopyImage := @Call32;
  @DrawIconEx := @Call32;
  id_W32SystemParametersInfo:=Declare32('SystemParametersInfo', 'user32', 'iipi');
  id_W32GetSystemMetrics:=Declare32('GetSystemMetrics', 'user32', 'i');
  id_W32GetVersionEx:=Declare32('GetVersionEx', 'kernel32', 'p');
  {Check if everything went well. Call32NTError=false means no errors at all}
  if Call32NTError then begin
    FOS_Bits := os16bit; { one or more  32  bit functions failed - so it's probably a 16bit OS }
  end else begin
    FOS_Bits := os32bit; { all 32 bit functions worked - so it's definitely a 32bit OS }
  end;
  { Icon routines not available on Win32s - so test separately }
  id_W32CopyImage:=Declare32('CopyImage', 'user32', 'iiiii');
  id_W32DrawIconEx:=Declare32('DrawIconEx', 'user32', 'iiiiiiiii');
  W32IconRoutinesAvailable := not Call32NTError;
{$endif}
end.





{**********************************************************************}
{** Note about MDI Applications                                      **}
{**              MDI Applications will have a drawing problem with   **}
{**              this caption component.  To avoid this I recommend  **}
{**              that you add code into your MainForm, so that when  **}
{**              a child form is created, then the following code    **}
{**              gets executed instead of the DELPHI supplied        **}
{**              routine for  "CreateMDIChild" .                       **}
{**                                                                  **}
{**              This code has been tested using an application      **}
{**              created with Delphi2's MDI application template.    **}
{**              (with a TMSOfficeCaption component added).          **}
{**                                                                  **}
{** What does it do?   ( 32  bit)                                      **}
{**              This code stops Windows from redrawing the caption  **}
{**              of the main window.  It then updates the caption    **}
{**              with the new name - flicker free.                   **}
{**                                                                  **}
{** What does it do?   ( 16  bit)                                      **}
{**              This code paints an updated caption after the       **}
{**              default actions.                                    **}
{**********************************************************************}

 --------------------
 
The  32  bit version :
 --------------------
 

procedure TForm1.CreateMDIChild(const Name: string);
var
  Child: TMDIChild;
  FFreezer : TFreezer;
begin
  { Protect window from updates/flicker }
  If (MSOfficeCaption1 <> nil) then FFreezer := MSOfficeCaption1.Freeze;

  { create a new MDI child window }
  Child := TMDIChild.Create(Application);
  Child.Caption := Name;

  If (MSOfficeCaption1 <> nil) then MSOfficeCaption1.UnFreeze(FFreezer);
  If (MSOfficeCaption1 <> nil) then MSOfficeCaption1.UpdateCaption;
end;
{**********************************************************************}

 --------------------
 
The  16  bit version :
 --------------------
 
procedure TForm1.CreateMDIChild(const Name: string);
var
  Child: TMDIChild;
begin
  { create a new MDI child window }
  Child := TMDIChild.Create(Application);
  Child.Caption := Name;

  If ((MSOfficeCaption1 <> nil) and (Child.WindowState=wsMaximized))
    then MSOfficeCaption1.UpdateCaption;
end;