cdibcontrol.pas

Delphi控件

unit cDIBControl;

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License
Version 1.1 (the "License"); you may not use this file except in compliance
with the License. You may obtain a copy of the License at
http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis,
WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for
the specific language governing rights and limitations under the License.

The Original Code is: cDIBControl.PAS, released August 28, 2000.

The Initial Developer of the Original Code is Peter Morris ([e-mail]),
Portions created by Peter Morris are Copyright (C) 2000 Peter Morris.
All Rights Reserved.

Purpose of file:
The main base component for all DIB components

Contributor(s):
None as yet


Last Modified: May 23, 2003

You may retrieve the latest version of this file at http://www.droopyeyes.com


Known Issues:
Would have been good if we could have derived this component from TCustomControl
instead.  If anyone can work out how to get this stuff to work just as well from
a TCustomControl I would love to hear from you !!!
-----------------------------------------------------------------------------}
//Modifications
(*
Date:   April 6, 2001
By:     Peter Morris
Change: Added HelpContext property, does nothing yet.

Date:   April 7, 2001
By:     Peter Morris
Change: Added OnPaint

Date:   April 7, 2001
By:     Peter Morris
Change: Moved the ControlDIB property to PUBLIC area

Date:   April 7, 2001
By:     Peter Morris
Change: Added a MousePosition property (TPoint)

Date:   April 16, 2001
By:     Peter Morris
Change: Added support for sub properties in template files (such as FONT)

Date:   May 2, 2001
By:     Peter Morris
Change: Added a new base control called TCustomDIBFramedControl

Date:   May 2, 2001
By:     Peter Morris
Change: Added BeforePaint and AfterPaint methods

Date:   August 19, 2001
By:     Peter Morris
Change: Removed the line of code in the constructor which automatically sets
        the parent of the DIBControl.  This causes many messages to occur
        such as CM_FONTCHANGED which can cause code to be executed before the
        constructor has completed.

Date:   August 24, 2001
By:     Peter Morris
Change: Moved "inherited" to the top of the Notification method in
        TCustomDIBControl, which was causing an endless loop when destroying
        in Delphi 6.

Date:   January 1, 2002 (Happy new year)
By:     Peter Morris
Change: Altered the SetTabOrder procedure, was causing an AV sometimes.

Date:   August 18, 2002
By:     Hans-J黵gen Schnorrenberg
Change: Intorduced method CMEnabledChanged, in order to kill focus, when disabled.
        WMSetFocus calls DoEnter, only when Enabled.

Date:   March 23, 2003
By:     Peter Morris
Change: Removed MouseDownButton and replaced with a set instead MouseButtons.

Date:   January 9, 2005
By:     Peter Morris
Change: Added TPointProperty
*)

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, cDIB,
  cDIBPanel, cDIBFeatures, ExtCtrls, Consts, Menus, cDIBTimer, cDIBImageList, TypInfo,
  cDIBCompressor, cDIBBorder;

type
  EDIBControlError = class(Exception);
  TWantedKey = (wkTab, wkArrows, wkAll);
  TWantedKeys = set of TWantedKey;

  TDIBDrawEvent = procedure(Sender: TObject; var Handled: Boolean) of object;
  TDIBMeasureEvent = procedure(Sender: TObject; var Size: Integer) of object;
  TDIBBackgroundStyle = (bsDrawSolid, bsDrawTransparent);

  TPointProperty = class(TPersistent)
  private
    FX: Integer;
    FY: Integer;
    FOnChanged: TNotifyEvent;
    procedure SetX(const Value: Integer);
    procedure SetY(const Value: Integer);
  protected
    procedure DoChanged;
  public
    constructor Create; virtual;
    procedure AssignTo(Dest: TPersistent); override;
    property OnChanged: TNotifyEvent read FOnChanged write FOnChanged;
  published
    property X: Integer read FX write SetX default 0;
    property Y: Integer read FY write SetY default 0;
  end;

  TCustomDIBControl = class(TControl)
  private
    { Private declarations }
    FLastInvalidateTime: DWORD;
    FPropertyList: TList;
    FDIBImageList: TCustomDIBImageList;
    FCanvas: TCanvas;
    FControlDIB: TWinDIB;
    FHelpContext: THelpContext;
    FAccelerator: Char;
    FCreating: Boolean;
    FFocused: Boolean;
    FStoppingRepeat: Boolean;
    FAlreadyMoving: Boolean;
    FChildren: TControlList;
    FMouseRepeat: Boolean;
    FMouseRepeatInterval: Integer;
    FMouseXPos: Integer;
    FMouseYPos: Integer;
    FShiftState: TShiftState;
    FTimer: TDIBTimer;
    FLastMouse: TMessage;
    FRealMouseInControl: Boolean;
    FMouseInControl: Boolean;
    FOnPaint,
    FOnEnter,
    FOnExit,
    FOnMouseEnter,
    FOnMouseLeave: TNotifyEvent;
    FDIBFeatures: TDIBFeatures;
    FOpacity: Byte;
    FOnKeyDown: TKeyEvent;
    FOnKeyUp: TKeyEvent;
    FOnKeyPress: TKeyPressEvent;
    FOnPaintStart: TNotifyEvent;
    FOnPaintEnd: TNotifyEvent;
    FMovingOnly: Boolean;
    FMouseButtons: TMouseButtons;

    //For streaming of properties to templates
    FPropertyNames: TStringList;
    procedure ReadProperties(S: TStream);
    procedure WriteProperties(S: TStream);

    procedure DoImageChanged(Sender: TObject; Index: Integer; Operation: TDIBOperation);
    function GetContainer: TCustomDIBContainer;
    function GetTabOrder: TTabOrder;
    procedure SetOpacity(const Value: Byte);
    procedure SetTabOrder(const Value: TTabOrder);
    procedure RepeatMessage(Sender: TObject);

    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DialogChar;
    procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
    // ** Hans-J黵gen
    procedure WMChar(var Message: TWMKey); message WM_Char;
    procedure WMGetDlgCode(var Message: TWMGetDlgCode); message WM_GetDlgCode;
    procedure WMKeyDown(var Message: TWMKey); message WM_KeyDown;
    procedure WMKeyUp(var Message: TWMKey); message WM_KeyUp;
    procedure WMKillFocus(var Message: TMessage); message WM_KillFocus;
    procedure WMPAINT(var Message: TMessage); message WM_Paint;
    procedure WMSetFocus(var Message: TMessage); message WM_SetFocus;
    procedure SetDIBImageList(const Value: TCustomDIBImageList);
    function GetMousePosition: TPoint;
  protected
    { Protected declarations }
    FTabOrder: TTabOrder;
    WantedKeys: TWantedKeys;

    procedure AddTemplateProperty(const Name: string);
    procedure AfterPaint; virtual;
    procedure AlterUpdateRect(var R: TRect); virtual;
    procedure AddIndexProperty(var Index: TDIBImageLink);
    procedure BeforePaint; virtual;
    procedure ClearDefaultPopupMenu(const PopupMenu: TPopupMenu); dynamic;
    procedure Click; override;
    procedure DoAnyEnter; virtual;
    procedure DoAnyLeave; virtual;
    procedure DoDefaultPopupMenu(const PopupMenu: TPopupMenu); dynamic;
    procedure DoEnter; virtual;
    procedure DoExit; virtual;
    function DoKeyDown(var Message: TWMKey): Boolean; virtual;
    function DoKeyPress(var Message: TWMKey): Boolean; virtual;
    function DoKeyUp(var Message: TWMKey): Boolean; virtual;
    procedure DoMouseEnter; virtual;
    procedure DoMouseLeave; virtual;
    function GetPopupMenu: TPopupMenu; override;
    procedure KeyDown(var Key: Word; Shift: TShiftState); dynamic;
    procedure KeyUp(var Key: Word; Shift: TShiftState); dynamic;
    procedure KeyPress(var Key: Char); dynamic;
    procedure ImageChanged(Index: Integer; Operation: TDIBOperation); virtual;
    function IsMenuKey(var Message: TWMKey): Boolean; virtual;
    function IsMouseRepeating: Boolean;
    procedure Loaded; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    procedure Paint; virtual;
    procedure SetParent(AParent: TWinControl); override;
    procedure StopRepeating; virtual;
    procedure WndProc(var Message: TMessage); override;

    property Accelerator: Char read FAccelerator write FAccelerator;
    property Canvas: TCanvas read FCanvas;
    property Children: TControlList read FChildren write FChildren;
    property Creating: Boolean read FCreating;
    property DIBFeatures: TDIBFeatures read FDIBFeatures write FDIBFeatures;
    property DIBImageList: TCustomDIBImageList read FDIBImageList write SetDIBImageList;
    property HelpContext: THelpContext read FHelpContext write FHelpContext default 0;
    property LastMouse: TMessage read FLastMouse;
    property MouseButtons: TMouseButtons read FMouseButtons;
    property MouseRepeat: Boolean read FMouseRepeat write FMouseRepeat;
    property MouseRepeatInterval: Integer read FMouseRepeatInterval
      write FMouseRepeatInterval;
    property Opacity: Byte read FOpacity write SetOpacity;
    property ShiftState: TShiftState read FShiftState write FShiftState;
    property DIBTabOrder: TTabOrder read GetTabOrder write SetTabOrder;

    property LastInvalidateTime: DWORD read FLastInvalidateTime;
    property MouseCaptured: Boolean read FMouseInControl;
//    property MouseDownButton: TMouseDownButton read FMouseDownButton;
    property MouseOver: Boolean read FRealMouseInControl;
    property MouseXPos: Integer read FMouseXPos;
    property MouseYPos: Integer read FMouseYPos;
    property MovingOnly: Boolean read FMovingOnly;

    property OnEnter: TNotifyEvent read FOnEnter write FOnEnter;
    property OnExit: TNotifyEvent read FOnExit write FOnExit;
    property OnKeyDown: TKeyEvent read FOnKeyDown write FOnKeyDown;
    property OnKeyPress: TKeyPressEvent read FOnKeyPress write FOnKeyPress;
    property OnKeyUp: TKeyEvent read FOnKeyUp write FOnKeyUp;
    property OnMouseEnter: TNotifyEvent read FOnMouseEnter write FOnMouseEnter;
    property OnMouseLeave: TNotifyEvent read FOnMouseLeave write FOnMouseLeave;
    property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
    property OnPaintStart: TNotifyEvent read FOnPaintStart write FOnPaintStart;
    property OnPaintEnd: TNotifyEvent read FOnPaintEnd write FOnPaintEnd;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    procedure Invalidate; override;
    procedure LoadTemplateFromFile(const Filename: TFilename);
    procedure LoadTemplateFromStream(const S: TStream); virtual;
    procedure SaveTemplateToFile(const Filename: TFilename);
    procedure SaveTemplateToStream(const S: TStream); virtual;

    procedure SetBounds(aLeft, aTop, aWidth, aHeight: Integer); override;
    procedure SetFocus;

    property Container: TCustomDIBContainer read GetContainer;
    property ControlDIB: TWinDIB read FControlDIB write FControlDIB;
    property Focused: Boolean read FFocused;
    property MouseInControl: Boolean read FMouseInControl;
    property MousePosition: TPoint read GetMousePosition;

  published
    { Published declarations }
  end;

  TCustomDIBFramedControl = class(TCustomDIBControl)
  private
    FBackgroundStyle: TDIBBackgroundStyle;
    FDIBBorder: TDIBBorder;
    FOnDrawBackground: TDIBDrawEvent;
    FOnDrawBorder: TDIBDrawEvent;
    FOnMeasureBottomBorder: TDIBMeasureEvent;
    FOnMeasureLeftBorder: TDIBMeasureEvent;
    FOnMeasureRightBorder: TDIBMeasureEvent;
    FOnMeasureTopBorder: TDIBMeasureEvent;
    procedure SetBackgroundStyle(const Value: TDIBBackgroundStyle);
  protected
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;

    procedure AfterPaint; override;
    procedure BeforePaint; override;
    procedure DrawBackground; virtual;
    procedure DrawBorder; virtual;
    function GetBottomBorderSize: Integer; virtual;
    function GetLeftBorderSize: Integer; virtual;
    function GetRightBorderSize: Integer; virtual;
    function GetTopBorderSize: Integer; virtual;
    procedure SetDIBBorder(const Value: TDIBBorder); virtual;

    property BackgroundStyle: TDIBBackgroundStyle 
      read FBackgroundStyle write SetBackgroundStyle default bsDrawSolid;
    property DIBBorder: TDIBBorder read FDIBBorder write SetDIBBorder;
    property OnDrawBackground: TDIBDrawEvent read FOnDrawBackground write FOnDrawBackground;
    property OnDrawBorder: TDIBDrawEvent read FOnDrawBorder write FOnDrawBorder;
    property OnMeasureBottomBorder: TDIBMeasureEvent
      read FOnMeasureBottomBorder write FOnMeasureBottomBorder;
    property OnMeasureLeftBorder: TDIBMeasureEvent
      read FOnMeasureLeftBorder write FOnMeasureLeftBorder;
    property OnMeasureRightBorder: TDIBMeasureEvent
      read FOnMeasureRightBorder write FOnMeasureRightBorder;
    property OnMeasureTopBorder: TDIBMeasureEvent
      read FOnMeasureTopBorder write FOnMeasureTopBorder;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
  end;

  //procedure AddDIBChildMessage(const Message : DWord);
  //function  FindDIBChildMessage(const Message : DWord) : Boolean;
  //procedure RemoveDIBChildMessage(const Message : DWord);

function GetPropertyName(aInstance: TComponent; aObject: TPersistent): string;

implementation

uses
  ActiveX, COMObj;

var
  GDefaultPopupMenu: TPopupMenu = nil;

type
  THackContainer = class(TCustomDIBContainer);
  THackFeatures = class(TDIBFeatures);
  THackControl = class(TControl);
  THackAbstractSuperDIB = class(TAbstractSuperDIB);
  THackWinControl = class(TWinControl);

  TDIBWrapper = class(TComponent)
  private
    FDIB: TMemoryDIB;
  published
    property DIB: TMemoryDIB read FDIB write FDIB;
  end;

  TPersistentWrapper = class(TComponent)
  private
    FPersistent: TPersistent;
  published
    property Persistent: TPersistent read FPersistent write FPersistent;
  end;

function GetPropertyName(aInstance: TComponent; aObject: TPersistent): string;
var
  TI: PTypeInfo;
  PI: PPropInfo;
  Cnt: Integer;
  Props: PPropList;
begin
  Result := '';

  TI := aInstance.ClassInfo;
  Cnt := GetTypeData(TI)^.PropCount;
  GetMem(Props, Cnt * SizeOf(PPropInfo));
  Cnt := GetPropList(TI, [tkClass], Props);
  for Cnt := Cnt - 1 downto 0 do
  begin
    PI := GetPropInfo(TI, Props[Cnt].Name);
    if GetOrdProp(aInstance, PI) = LongInt(aObject) then
    begin
      Result := Props[Cnt].Name;
      break;
    end;
  end;
  FreeMem(Props);
end;

{ TPointProperty }

procedure TPointProperty.AssignTo(Dest: TPersistent);
begin
  if (Dest is TPointProperty) then
  begin
    TPointProperty(Dest).X := X;
    TPointProperty(Dest).Y := Y;
  end else
    inherited;
end;

constructor TPointProperty.Create;
begin
  inherited Create;
  FX := 0;
  FY := 0;
end;

procedure TPointProperty.DoChanged;
begin
  if Assigned(OnChanged) then
    OnChanged(Self);
end;

procedure TPointProperty.SetX(const Value: Integer);
begin
  FX := Value;
  DoChanged;
end;

procedure TPointProperty.SetY(const Value: Integer);
begin
  FY := Value;
  DoChanged;
end;

{ TCustomDIBControl }

constructor TCustomDIBControl.Create(AOwner: TComponent);
var
  X: Integer;
  P: TWinControl;
begin
  P := nil;
  if AOwner = nil then raise Exception.Create('Owner cannot be nil');

  if AOwner is TCustomDIBContainer then
    P := TWinControl(AOwner)
  else
    for X := 0 to AOwner.ComponentCount - 1 do
      if AOwner.Components[X] is TCustomDIBContainer then 
      begin
        P := TWinControl(AOwner.Components[X]);
        Break;
      end;

  if P = nil then raise Exception.Create('Parent must be a TDIBContainer');
  FCreating := True;
  inherited;
  FPropertyList := TList.Create;
  FPropertyNames := TStringList.Create;
  FCanvas := TCanvas.Create;
  FAlreadyMoving := False;
  FStoppingRepeat := False;
  FChildren := TControlList.Create(Self);
  //This causes CM_FONTCHANGE which triggers methods before the constructor has
  //been completed.
  //  Parent := P;
  SetBounds(0, 0, 32, 32);
  FDIBFeatures := TDIBFeatures.Create(Self);
  FOpacity := 255;
  FMouseInControl := False;
  FRealMouseInControl := False;
  FTimer := TDIBTimer.Create(nil);
  FTimer.OnTimer := RepeatMessage;
  FTimer.Enabled := False;
//  FMouseDownButton := mdNone;
  FMouseRepeat := False;
  FMouseRepeatInterval := 250;
  FTabOrder := -1;
  WantedKeys := [wkArrows];
  AddTemplateProperty('Width');
  AddTemplateProperty('Height');
end;

destructor TCustomDIBControl.Destroy;
begin
  FPropertyNames.Free;
  FTimer.Free;
  FChildren.Free;
  FDIBFeatures.Free;
  FCanvas.Free;
  FPropertyList.Free;
  inherited;
end;

procedure TCustomDIBControl.Loaded;
begin
  FCreating := False;
  inherited;
  THackFeatures(FDIBFeatures).Loaded;
  DIBTabOrder := FTabOrder;
end;

function TCustomDIBControl.IsMenuKey(var Message: TWMKey): Boolean;
var
  Control: TControl;
  Form: TCustomForm;
begin
  Result := True;
  if not (csDesigning in ComponentState) then
  begin
    Control := Self;
    while Control <> nil do
    begin
      if Assigned(PopupMenu) and (PopupMenu.WindowHandle <> 0) and
        PopupMenu.IsShortCut(Message) then Exit;
      Control := Control.Parent;
    end;