mmform.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Tel.: [phone]                   =}
{=  Loewenstr.7a                = [e-mail]                     =}
{========================================================================}
{=  Actual versions on http://www.swiftsoft.de/mmtools.html             =}
{========================================================================}
{=  This code is for reference purposes only and may not be copied or   =}
{=  distributed in any format electronic or otherwise except one copy   =}
{=  for backup purposes.                                                =}
{=                                                                      =}
{=  No Delphi Component Kit or Component individually or in a collection=}
{=  subclassed or otherwise from the code in this unit, or associated   =}
{=  .pas, .dfm, .dcu, .asm or .obj files may be sold or distributed     =}
{=  without express permission from SwiftSoft.                          =}
{=                                                                      =}
{=  For more licence informations please refer to the associated        =}
{=  HelpFile.                                                           =}
{========================================================================}
{=  $Date: 19.02.98 - 16:04:37 $                                        =}
{========================================================================}
unit MMForm;

{$I COMPILER.INC}

{$D+,L+}

interface

uses
    Windows,
    Messages,
    SysUtils,
    Classes,
    Graphics,
    Controls,
    Forms,
    Dialogs,
    StdCtrls,
    ExtCtrls,
    ShellApi,
    MMObj,
    MMUtils,
    MMHook;

type
  TMMFormStyler = class;
  TMMFontKind    = (fkCustom, fkSystem, fkSystemI, fkSystemB, fkSystemBI, fkAutoHeight);

  {== TMMCompanyText ==========================================================}
  TMMCompanyText = class(TPersistent)
  private
    FCaption      : String;
    FColorActive  : TColor;
    FColorInactive: TColor;
    FFont         : TFont;
    FFontKind     : TMMFontKind;
    FOwner        : TMMFormStyler;
    FVisible      : Boolean;

    function  StoreFont: Boolean;
    procedure SetColorActive(Value: TColor);
    procedure SetColorInactive(Value: TColor);
    procedure SetCaption(Value: String); virtual;
    procedure SetFont(Value: TFont);
    procedure SetFontKind(Value: TMMFontKind);
    procedure SetVisible(Value: Boolean);
    procedure SetFontKind_NoRedraw(Value: TMMFontKind);

  public
    constructor Create(AOwner: TMMFormStyler); virtual;
    destructor  Destroy; override;

  published
    property Caption: String read FCaption write SetCaption;
    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: TMMFontKind read FFontKind write SetFontKind;
    property Visible: Boolean read FVisible write SetVisible;
  end;

  TMMAppNameText = class(TMMCompanyText)
  end;

  TMMCaptionText = class(TMMCompanyText)
  protected
    function  GetCaption: String; virtual;
  published
    property Caption : String read GetCaption write SetCaption;
  end;

  {== TMMFormStyler ===========================================================}
  TMMGradientColors  = 2..236;
  TMMGradientOptions = (goAlways, goNever, goActive, goSmart);

  TMMFormStyler = class(TMMWndProcComponent)
  private
    FHandle           : THandle;
    FAppNameText      : TMMAppNameText;
    FCaptionText      : TMMCaptionText;
    FCompanyText      : TMMCompanyText;

    FClrLeftActive    : TColor;
    FClrLeftInActive  : TColor;
    FClrRightActive   : TColor;
    FClrRightInActive : TColor;

    FOptions          : TMMGradientOptions;
    FNumColors        : TMMGradientColors;
    FAlignment        : TAlignment;

    FSystemFont       : TFont;
    FWindowActive     : Boolean;
    FActiveDefined    : Boolean;
    FRecreating       : Boolean;

    procedure SetColors(index: integer; aValue: TColor);
    procedure SetAlignment(aValue: TAlignment);
    procedure SetNumColors(aValue: TMMGradientColors);
    procedure SetOptions(aValue: TMMGradientOptions);

    function  GetVisibleButtons: TBorderIcons;
    procedure ExcludeBtnRgn (var R: TRect);
    procedure GetSystemFont(Font: TFont);
    function  GetTextRect: TRect;
    function  GetTitleBarRect: TRect;
    function  MeasureText(DC: HDC; R: TRect; Text: TMMCompanyText): integer;
    procedure NewCaptionText;
    procedure PaintMenuIcon(DC: HDC; var R: TRect);
    procedure PaintCaptionText(DC: HDC; var R: TRect; Text: TMMCompanyText; Active: Boolean);

    procedure PaintCaptionButtons(DC: HDC; var Rect: TRect);
    procedure PerformNCPaint(var AMsg: TMessage);
    procedure PerformNCActivate(var AMsg: TMessage);
    function  HandleWMSetCursor(var Msg: TWMSetCursor): Boolean;

    procedure SetAutoFontHeight(Font: TFont);
    function  WindowIsActive: Boolean;

  protected
    procedure Loaded; override;
    procedure HookWndProc(var Message: TMessage); override;
    procedure HookAppWndProc(var AMsg: TMessage);
{$IFDEF BUILD_ACTIVEX}
    procedure ChangeDesigning(Value: Boolean); override;
    function GetOwnerCaption: string;
    procedure HookOwner; override;
    procedure UnhookOwner; override;
    procedure CMEnabledChanged(var M: TMessage); message CM_ENABLEDCHANGED;
{$ELSE}
    procedure ChangeDesigning(Value: Boolean);
{$ENDIF}

  public
    constructor Create(AOwner: TComponent);  override;
    destructor  Destroy; override;

    procedure   UpdateCaption;
    function    DrawCaption(Active: Boolean): TRect;

  published
{$IFDEF BUILD_ACTIVEX}
    property Enabled;
{$ENDIF}

    property AppNameText: TMMAppNameText read FAppNameText write FAppNameText;
    property CaptionText: TMMCaptionText read FCaptionText write FCaptionText;
    property CompanyText: TMMCompanyText read FCompanyText write FCompanyText;

    property ClrLeftActive   : TColor index 0 read FClrLeftActive write SetColors default clBlack;
    property ClrLeftInActive : TColor index 1 read FClrLeftInActive write SetColors default clBlack;
    property ClrRightActive  : TColor index 2 read FClrRightActive write SetColors default clActiveCaption;
    property ClrRightInActive: TColor index 3 read FClrRightInActive write SetColors default clInActiveCaption;

    property Alignment: TAlignment read FAlignment write SetAlignment default taLeftJustify;
    property Options  : TMMGradientOptions read FOptions write SetOptions default goSmart;
    property NumColors: TMMGradientColors read FNumColors write SetNumColors default 64;
  end;


implementation

{$IFDEF DELPHI3} resourcestring {$ELSE} const {$ENDIF}
  SSecondStyler = 'Only one FormStyler is allowed per Form';

const
   ControlList: TList = nil;
   WordSpacing        = 3;
   MM_RecreateNotify  = WM_USER + 12621;

{== TMMCompanyText ============================================================}
constructor TMMCompanyText.Create(AOwner: TMMFormStyler);
begin
   inherited Create;

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

{-- TMMCompanyText ------------------------------------------------------------}
destructor TMMCompanyText.Destroy;
begin
   FFont.Free;
   inherited destroy;
end;

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

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

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

{-- TMMCompanyText ------------------------------------------------------------}
procedure TMMCompanyText.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;

{-- TMMCompanyText ------------------------------------------------------------}
function TMMCompanyText.Storefont : Boolean;
begin
   Result := not (FFontKind in [fkSystem, fkSystemB, fkSystemBI, fkSystemI]);
end;

{-- TMMCompanyText ------------------------------------------------------------}
procedure TMMCompanyText.SetFontKind(Value: TMMFontKind);
begin
   SetFontKind_NoRedraw(Value);
   if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;

{-- TMMCompanyText ------------------------------------------------------------}
procedure TMMCompanyText.SetFontKind_NoRedraw(Value: TMMFontKind);
begin
   FFontKind := Value;
   case FFontKind of
      fkCustom : { do nothing special };
      fkSystem : FFont.Assign(FOwner.FSystemFont);
      fkSystemI:
      begin
         FFont.Assign(FOwner.FSystemFont);
         FFont.Style := FFont.Style + [fsItalic];
      end;
      fkSystemB:
      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;
end;

{-- TMMCompanyText ------------------------------------------------------------}
procedure TMMCompanyText.SetVisible(Value: Boolean);
begin
   if FVisible = Value then exit;

   FVisible := Value;
   FOwner.NewCaptionText;
   if csDesigning in FOwner.ComponentState then FOwner.UpdateCaption;
end;

{== TMMCaptionText ============================================================}
function TMMCaptionText.GetCaption: String;
var
   temp : string;
   found: integer;

begin
   try
{$IFNDEF BUILD_ACTIVEX}
      if FOwner.OwnerForm = nil then
      begin
         Result := '';
         exit;
      end;
      temp := FOwner.OwnerForm.Caption;
{$ELSE}
      if FOwner.HookWnd = 0 then
      begin
        Result := '';
        exit;
      end;
      temp := FOwner.GetOwnerCaption;
{$ENDIF}
      if FOwner.FCompanyText.Visible then
      begin
         Found := Pos(FOwner.FCompanyText.Caption, Temp);
         if found <> 0 then temp := Copy(temp, found + length(FOwner.FCompanyText.Caption), maxint);
         if length(temp) > 0 then if temp[1] = ' ' then temp := Copy(temp, 2, maxint);
      end;
      if FOwner.FAppNameText.Visible then
      begin
         found := Pos(FOwner.FAppNameText.Caption, Temp);
         if found <> 0 then temp := Copy(temp, found + length(FOwner.FAppNameText.Caption), maxint);
         if length(temp) > 0 then if temp[1] = ' ' then temp := Copy(temp, 2, maxint);
      end;
      Result := temp;
   except
      Result := '';
   end;
end;

{------------------------------------------------------------------------}
procedure AddStyler(Comp: TMMFormStyler);
begin
   if (ControlList = nil) then ControlList := TList.Create;
   ControlList.Add(Comp);
end;

{------------------------------------------------------------------------}
procedure RemoveStyler(Comp: TMMFormStyler);
begin
   ControlList.Remove(Comp);
   if (ControlList.Count = 0) then
   begin
      ControlList.Free;
      ControlList := nil;
   end;
end;

{------------------------------------------------------------------------}
function FindStylerForWindow(Wnd: HWND): TMMFormStyler;
var
   i: Integer;
begin
   { It is no sense to have multiple different designers for one window }
   if (ControlList <> nil) and (ControlList.Count > 0) then
   for i := 0 to ControlList.Count-1 do
   begin