formskin.pas

GREATIS Print Suite Pro for Delphi (3-7,2005,2006,2007) and C++ Builder (3-6) Set of components for

(*  GREATIS BONUS * Form Skin                 *)
(*  Copyright (C) 1998-2007 Greatis Software  *)
(*  http://www.greatis.com/delphibonus.htm    *)

unit FormSkin;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, Menus;

type

  EFormSkinException = class(Exception);

  TSkinOption = (soCaption,soBorder,soControls,soSkin,soAutoSize,soClientDrag);
  TSkinOptions = set of TSkinOption;

  THitArea = (
    haNone,
    haClient,
    haCaptionBar,
    haSysMenu,
    haMinimizeButton,
    haMaximizeButton,
    haCloseButton,
    haTopBorder,
    haBottomBorder,
    haLeftBorder,
    haRightBorder,
    haTopLeftCorner,
    haTopRightCorner,
    haBottomLeftCorner,
    haBottomRightCorner,
    haGrowBox);

  THitAreaEvent = procedure(Sender: TObject; X,Y: Integer; var Area: THitArea) of object;
  TTransparencyEvent = procedure(Sender: TObject; X,Y: Integer; var Transparent: Boolean) of object;
  TControlTransparencyEvent = procedure(Sender: TObject; Control: TControl; var Transparent: Boolean) of object;

  TCustomFormSkin = class(TComponent)
  private
    { Private declarations }
    FRegion: HRGN;
    FLockSizeMessages: Boolean;
    FOptions: TSkinOptions;
    FActive: Boolean;
    FPopupMenu: TPopupMenu;
    FDefaultProc: TFarProc;
    FHookProc: Pointer;
    FOnHitArea: THitAreaEvent;
    FOnTransparency: TTransparencyEvent;
    FOnControlTransparency: TControlTransparencyEvent;
    procedure SetOptions(const Value: TSkinOptions);
    procedure SetActive(const Value: Boolean);
    function BorderHeight: Integer;
    function BorderWidth: Integer;
    procedure HookProc(var Message: TMessage);
    function HitAreaToHitTest(Value: THitArea): Integer;
    function HitTestToHitArea(Value: Integer): THitArea;
  protected
    { Protected declarations }
    procedure HitArea(X,Y: Integer; var Area: THitArea); virtual;
    function CreateRegion: HRGN; virtual;
    function CreateCaptionRegion: HRGN; virtual;
    function CreateBorderRegion: HRGN; virtual;
    function CreateControlsRegion: HRGN; virtual;
    function CreateSkinRegion: HRGN; virtual;
    function GetSkinWidth: Integer; virtual;
    function GetSkinHeight: Integer; virtual;
    function IsTransparent(X,Y: Integer): Boolean; virtual;
    function IsTransparentControl(Control: TControl): Boolean; virtual;
    property Options: TSkinOptions read FOptions write SetOptions;
    property Active: Boolean read FActive write SetActive;
    property PopupMenu: TPopupMenu read FPopupMenu write FPopupMenu;
    property OnHitArea: THitAreaEvent read FOnHitArea write FOnHitArea;
    property OnTransparency: TTransparencyEvent read FOnTransparency write FOnTransparency;
    property OnControlTransparency: TControlTransparencyEvent read FOnControlTransparency write FOnControlTransparency;
  public
    { Public declarations }
    destructor Destroy; override;
    procedure Update; virtual;
  published
    { Published declarations }
  end;

  TSimpleFormSkin = class(TCustomFormSkin)
  published
    { Published declarations }
    property Options;
    property Active;
    property PopupMenu;
    property OnHitArea;
    property OnTransparency;
    property OnControlTransparency;
  end;

  TBitmapFormSkin = class(TCustomFormSkin)
  private
    { Private declarations }
    FDesignBrush: TBrush;
    FTransparentColor: TColor;
    FSkin: TBitmap;
    FPreview: Boolean;
    procedure SetTransparentColor(const Value: TColor);
    procedure SetSkin(const Value: TBitmap);
    procedure SetPreview(const Value: Boolean);
    procedure AssignBrush;
    procedure RestoreBrush;
    procedure SkinChange(Sender: TObject);
  protected
    { Protected declarations }
    function GetSkinWidth: Integer; override;
    function GetSkinHeight: Integer; override;
    function IsTransparent(X,Y: Integer): Boolean; override;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    procedure Update; override;
  published
    { Published declarations }
    property TransparentColor: TColor read FTransparentColor write SetTransparentColor;
    property Skin: TBitmap read FSkin write SetSkin;
    property Preview: Boolean read FPreview write SetPreview;
    property Options;
    property Active;
    property PopupMenu;
    property OnHitArea;
    property OnControlTransparency;
  end;

procedure Register;

implementation

procedure TCustomFormSkin.SetOptions(const Value: TSkinOptions);
begin
  if FOptions<>Value then
  begin
    FOptions:=Value;
    Update;
  end;
end;

procedure TCustomFormSkin.SetActive(const Value: Boolean);
begin
  if FActive<>Value then
  begin
    FActive:=Value;
    if Assigned(Owner) then
      if FActive then
      begin
        FDefaultProc:=TFarProc(GetWindowLong(TForm(Owner).Handle,GWL_WNDPROC));
        FHookProc:=MakeObjectInstance(HookProc);
        SetWindowLong(TForm(Owner).Handle,GWL_WNDPROC,Integer(FHookProc));
      end
      else
      begin
        if Assigned(FDefaultProc) then SetWindowLong(TForm(Owner).Handle,GWL_WNDPROC,Integer(FDefaultProc));
        if Assigned(FHookProc) then FreeObjectInstance(FHookProc);
        FDefaultProc:=nil;
        FHookProc:=nil;
      end;
    if not (csDestroying in ComponentState) then Update;
  end;
end;

function TCustomFormSkin.BorderHeight: Integer;
begin
  case TForm(Owner).BorderStyle of
    bsSingle,bsDialog,bsToolWindow: Result:=GetSystemMetrics(SM_CYFIXEDFRAME);
    bsSizeToolWin,bsSizeable: Result:=GetSystemMetrics(SM_CYSIZEFRAME);
  else Result:=0;
  end;
end;

function TCustomFormSkin.BorderWidth: Integer;
begin
  case TForm(Owner).BorderStyle of
    bsSingle,bsDialog,bsToolWindow: Result:=GetSystemMetrics(SM_CXFIXEDFRAME);
    bsSizeToolWin,bsSizeable: Result:=GetSystemMetrics(SM_CXSIZEFRAME);
  else Result:=0;
  end;
end;

procedure TCustomFormSkin.HitArea(X,Y: Integer; var Area: THitArea);
begin
  if Assigned(FOnHitArea) then FOnHitArea(Self,X,Y,Area);
end;

function TCustomFormSkin.CreateRegion: HRGN;
var
  RGN: HRGN;
begin
  Result:=0;
  if soCaption in FOptions then
  begin
    if Result=0 then Result:=CreateRectRgn(0,0,0,0);
    RGN:=CreateCaptionRegion;
    try
      CombineRgn(Result,Result,RGN,RGN_OR);
    finally
      DeleteObject(RGN);
    end;
  end;
  if soBorder in FOptions then
  begin
    if Result=0 then Result:=CreateRectRgn(0,0,0,0);
    RGN:=CreateBorderRegion;
    try
      CombineRgn(Result,Result,RGN,RGN_OR);
    finally
      DeleteObject(RGN);
    end;
  end;
  if soSkin in FOptions then
  begin
    if Result=0 then Result:=CreateRectRgn(0,0,0,0);
    RGN:=CreateSkinRegion;
    try
      CombineRgn(Result,Result,RGN,RGN_OR);
    finally
      DeleteObject(RGN);
    end;
  end;
  if soControls in FOptions then
  begin
    if Result=0 then Result:=CreateRectRgn(0,0,0,0);
    RGN:=CreateControlsRegion;
    try
      CombineRgn(Result,Result,RGN,RGN_OR);
    finally
      DeleteObject(RGN);
    end;
  end;
end;

function TCustomFormSkin.CreateCaptionRegion: HRGN;
var
  R: TRect;
begin
  with TForm(Owner),R do
    if BorderStyle=bsNone then Result:=0
    else
    begin
      ZeroMemory(@R,SizeOf(R));
      if BorderStyle in [bsToolWindow,bsSizeToolWin] then
        Bottom:=Pred(GetSystemMetrics(SM_CYSMCAPTION))
      else Bottom:=Pred(GetSystemMetrics(SM_CYCAPTION));
      Right:=Width;
      InflateRect(R,-Self.BorderWidth,0);
      OffsetRect(R,0,BorderHeight);
      Result:=CreateRectRgn(Left,Top,Right,Bottom);
    end;
end;

function TCustomFormSkin.CreateBorderRegion: HRGN;
var
  RGN: HRGN;
begin
  with TForm(Owner) do
  begin
    Result:=CreateRectRgn(0,0,Width,Height);
    RGN:=CreateRectRgn(Self.BorderWidth,BorderHeight,Width-Self.BorderWidth,Height-BorderHeight);
    try
      CombineRgn(Result,Result,RGN,RGN_XOR);
    finally
      DeleteObject(RGN);
    end;
  end;
end;

function TCustomFormSkin.CreateControlsRegion: HRGN;
var
  RGN: HRGN;
  i: Integer;
begin
  with TForm(Owner) do
  begin
    Result:=CreateRectRgn(0,0,0,0);
    for i:=0 to Pred(ControlCount) do
      if not IsTransparentControl(Controls[i]) then
        with Controls[i].BoundsRect do
        begin
          RGN:=CreateRectRgn(Left,Top,Right,Bottom);
          try
            with TForm(Self.Owner),ClientOrigin do OffsetRgn(RGN,X-Left,Y-Top);
            CombineRgn(Result,Result,RGN,RGN_OR);
          finally
            DeleteObject(RGN);
          end;
        end;
  end;
end;

function TCustomFormSkin.CreateSkinRegion: HRGN;
var
  RGN: HRGN;
  X,XStart,Y: Integer;
  TRP: Boolean;
begin
  Result:=CreateRectRgn(0,0,0,0);
  for Y:=0 to Pred(GetSkinHeight) do
  begin
    XStart:=0;
    TRP:=IsTransparent(0,Y);
    for X:=0 to Pred(GetSkinWidth) do
    begin
      if IsTransparent(X,Y)<>TRP then
      begin
        if TRP then XStart:=X
        else
        begin
          RGN:=CreateRectRgn(XStart,Y,X,Succ(Y));
          try
            with TForm(Owner),ClientOrigin do OffsetRgn(RGN,X-Left,Y-Top);
            CombineRgn(Result,Result,RGN,RGN_OR);
          finally