Delphi控件源码

开发平台：
Delphi

MMObj.pas：源码内容
							{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: +49 (0)351-8037944              =}
{=  Loewenstr.7a                = info@swiftsoft.de                     =}
{========================================================================}
{=  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: 11.09.98 - 15:45:37 $                                        =}
{========================================================================}
unit MMObj;
{$I COMPILER.INC}
{$IFDEF TRIAL}
     {$IFNDEF CBUILDER3}
          {$DEFINE USE_ABOUT}
     {$ENDIF}
     {$IFDEF CBUILDER4}
          {$DEFINE USE_ABOUT}
     {$ENDIF}
{$ENDIF}
interface
Uses
{$IFDEF WIN32}
    Windows,
    SyncObjs,
{$ELSE}
    WinTypes,
    WinProcs,
{$ENDIF}
    SysUtils,
    Dialogs,
    Messages,
    Classes,
    Controls,
    ExtCtrls,
    Forms,
    Graphics,
    MMAbout;
const
    defWidth  = 28;
    defHeight = 28;
type
    {$IFDEF WIN32}
    {-- TMMCriticalSection ----------------------------------------------------}
    TMMCriticalSection = class(TCriticalSection)
    private
        FLockCount: integer;
    public
        property  LockCount: integer read FLockCount;
        procedure Acquire; override;
        procedure Release; override;
        function TryEnter: Boolean;
    end;
    {-- TMMThread -------------------------------------------------------------}
    TMMThreadEx = class(TThread)
    private
        function GetPriority: TThreadPriority;
        procedure SetPriority(Value: TThreadPriority);
    public
        property Priority: TThreadPriority read GetPriority write SetPriority;
    end;
    {$ENDIF}
    {-- TMMObject -------------------------------------------------------------}
    TMMObject = class(TPersistent)
    private
        FUpdateCount: integer;
        FOnChanging : TNotifyEvent;
        FOnChange   : TNotifyEvent;
    protected
        procedure SetUpdateState(Updating: Boolean); virtual;
        procedure Changing; dynamic;
        procedure Changed; dynamic;
    public
        procedure BeginUpdate;
        procedure EndUpdate;
        property  UpdateCount: integer read FUpdateCount;
        property  OnChanging: TNotifyEvent read FOnChanging write FOnChanging;
        property  OnChange: TNotifyEvent read FOnChange write FOnChange;
    end;
    {-- TMMBevel --------------------------------------------------------------}
    TMMBevel = class(TMMObject)
    private
        FBevelInner      : TPanelBevel;
        FBevelOuter      : TPanelBevel;
        FBevelInnerWidth : TBevelWidth;
        FBevelOuterWidth : TBevelWidth;
        FBorderStyle     : TBorderStyle;
        FBorderWidth     : TBorderWidth;
        FBorderSpace     : TBorderWidth;
        FBorderColor     : TColor;
        FBorderSpaceColor: TColor;
        FInnerLightColor : TColor;
        FInnerShadowColor: TColor;
        FOuterLightColor : TColor;
        FOuterShadowColor: TColor;
        function  GetBevelExtend: Integer;
        procedure SetBevelInner(Value: TPanelBevel);
        procedure SetBevelOuter(Value: TPanelBevel);
        procedure SetBevelInnerWidth(Value: TBevelWidth);
        procedure SetBevelOuterWidth(Value: TBevelWidth);
        procedure SetBorderStyle(Value: TBorderStyle);
        procedure SetBorderWidth(Value: TBorderWidth);
        procedure SetBorderSpace(Value: TBorderWidth);
        procedure SetColors(Index: Integer; Value: TColor);
    public
        constructor Create; virtual;
        procedure Assign(Source: TPersistent); override;
        property BevelExtend: Integer read GetBevelExtend;
        function PaintBevel(Canvas: TCanvas; FrameRect: TRect; Fill: Boolean): TRect; virtual;
    published
        property BevelInner: TPanelBevel read FBevelInner write SetBevelInner
                 {$IFDEF BUILD_ACTIVEX} default bvNone {$ENDIF};
        property BevelOuter: TPanelBevel read FBevelOuter write SetBevelOuter
                 {$IFDEF BUILD_ACTIVEX} default bvLowered {$ENDIF};
        property BevelInnerWidth: TBevelWidth read FBevelInnerWidth write SetBevelInnerWidth
                 {$IFDEF BUILD_ACTIVEX} default 1 {$ENDIF};
        property BevelOuterWidth: TBevelWidth read FBevelOuterWidth write SetBevelOuterWidth
                 {$IFDEF BUILD_ACTIVEX} default 1 {$ENDIF};
        property BorderStyle: TBorderStyle read FBorderStyle write SetBorderStyle
                 {$IFDEF BUILD_ACTIVEX} default bsNone {$ENDIF};
        property BorderWidth: TBorderWidth read FBorderWidth write SetBorderWidth
                 {$IFDEF BUILD_ACTIVEX} default 0 {$ENDIF};
        property BorderSpace: TBorderWidth read FBorderSpace write SetBorderSpace
                 {$IFDEF BUILD_ACTIVEX} default 0 {$ENDIF};
        property BorderColor: TColor index 0 read FBorderColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBtnFace {$ENDIF};
        property BorderSpaceColor: TColor index 1 read FBorderSpaceColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBlack {$ENDIF};
        property InnerLightColor : TColor index 2 read FInnerLightColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBtnHighlight {$ENDIF};
        property InnerShadowColor: TColor index 3 read FInnerShadowColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBtnShadow {$ENDIF};
        property OuterLightColor : TColor index 4 read FOuterLightColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBtnHighlight {$ENDIF};
        property OuterShadowColor: TColor index 5 read FOuterShadowColor write SetColors
                 {$IFDEF BUILD_ACTIVEX} default clBtnShadow {$ENDIF};
    end;
    {-- TMMComponent ----------------------------------------------------------}
    TMMComponent = class(TComponent)
    private
        {$IFDEF USE_ABOUT}
        FAbout   : TMMAboutBox;
        {$ENDIF}
    public
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
        {$ENDIF}
    end;
    {$IFDEF BUILD_ACTIVEX}
    {-- TMMAXControl ----------------------------------------------------------}
    TMMAXControl = class(TCustomControl)
    private
       FSelected: Boolean;
       procedure SetSelected(aValue: Boolean);
    public
       property Canvas;
       property Selected: Boolean read FSelected write SetSelected;
    end;
    {$ENDIF}
    {-- TMMNonVisualComponent -------------------------------------------------}
    {$IFNDEF BUILD_ACTIVEX}
    TMMNonVisualComponent = class(TMMComponent);
    {$ELSE}
    TMMNonVisualComponent = class(TMMAXControl)
    private
        FToolboxImageID: integer;
    protected
        procedure Paint; override;
        procedure SetBounds(ALeft, ATop, AWidth, AHeight: Integer); override;
    public
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
        constructor Create(aOwner: TComponent); override;
        property Width stored False;
        property Height stored False;
        property Font stored False;
        property Cursor stored False;
        property ToolboxImageID: integer read FToolboxImageID write FToolboxImageID;
    published
    end;
    {$ENDIF}
    {-- TMMWinControl ---------------------------------------------------------}
    TMMWinControl = class(TWinControl)
    private
        {$IFDEF USE_ABOUT}
        FAbout: TMMAboutBox;
        {$ENDIF}
    public
        constructor Create(aOwner: TComponent); override;
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
        function  ClientToClient(Source: TControl; const Point: TPoint): TPoint;
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
        {$ENDIF}
    end;
    {-- TMMCustomControl ------------------------------------------------------}
    {$IFDEF BUILD_ACTIVEX}
    TMMCustomControl = class(TMMAXControl)
    {$ELSE}
    TMMCustomControl = class(TCustomControl)
    {$ENDIF}
    private
        {$IFDEF USE_ABOUT}
        FAbout: TMMAboutBox;
        {$ENDIF}
        FBevel: TMMBevel;
        {$IFDEF BUILD_ACTIVEX}
        FTransparent: Boolean;
        {$ENDIF}
        procedure SetBevel(aValue: TMMBevel);
        procedure BevelChanged(Sender: TObject);
        {$IFDEF BUILD_ACTIVEX}
        procedure SetTransparent(aValue: Boolean);
        {$ENDIF}
    protected
        procedure Paint; override;
        procedure Changed; dynamic;
        {$IFDEF BUILD_ACTIVEX}
        procedure WMEraseBkgnd(var Message: TMessage); message WM_ERASEBKGND;
        procedure WMWindowPosChanging(var Message: TMessage); message WM_WINDOWPOSCHANGING;
        procedure CreateParams(var Params: TCreateParams); override;
        property  Transparent: Boolean read FTransparent write SetTransparent default False;
        {$ENDIF}
        property  Bevel: TMMBevel read FBevel write SetBevel;
    public
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
        function ClientToClient(Source: TControl; const Point: TPoint): TPoint;
        function BevelExtend: Integer;
        function BeveledRect: TRect;
        function ScreenRect(aRect: TRect): TRect;
        property Canvas;
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
        {$ENDIF}
    end;
    {-- TMMClientPaint --------------------------------------------------------}
    TMMClientFill = procedure(Sender: TObject; Canvas: TCanvas; aRect: TRect) of object;
    {-- TMMCustomPanel --------------------------------------------------------}
    TMMCustomPanel = class(TCustomPanel)
    private
          {$IFDEF USE_ABOUT}
           FAbout    : TMMAboutBox;
           {$ENDIF}
           FBevel    : TMMBevel;
           FOnPaint  : TNotifyEvent;
           FOnFill   : TMMClientFill;
           FFillBevel: Boolean;
           procedure SetBevel(aValue: TMMBevel);
           procedure BevelChanged(Sender: TObject);
           procedure SetFillBevel(aValue: Boolean);
           
    protected
        procedure AlignControls(aControl: TControl; var Rect: TRect); override;
        procedure Paint; override;
        procedure Changed; dynamic;
        property  Bevel: TMMBevel read FBevel write SetBevel;
        property  FillBevel: Boolean read FFillBevel write SetFillBevel default True;
    public
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
        function ClientToClient(Source: TControl; const Point: TPoint): TPoint;
        function BevelExtend: Integer;
        function BeveledRect: TRect;
        function ScreenRect(aRect: TRect): TRect;
        property OnPaint: TNotifyEvent read FOnPaint write FOnPaint;
        property OnFill: TMMClientFill read FOnFill write FOnFill;
        property Canvas;
        property Caption;
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
       {$ENDIF}
    end;
    {-- TMMGraphicControl -----------------------------------------------------}
    {$IFDEF BUILD_ACTIVEX}
    TMMGraphicControl = class(TMMCustomControl);
    {$ELSE}
    TMMGraphicControl = class(TGraphicControl)
    private
        {$IFDEF USE_ABOUT}
        FAbout: TMMAboutBox;
        {$ENDIF}
        FBevel: TMMBevel;
        FTransparent: Boolean;
        procedure SetBevel(aValue: TMMBevel);
        procedure SetTransparent(aValue: Boolean);
        procedure BevelChanged(Sender: TObject);
    protected
        procedure Paint; override;
        procedure Changed; dynamic;
        property  Bevel: TMMBevel read FBevel write SetBevel;
        property  Transparent: Boolean read FTransparent write SetTransparent default False;
    public
        constructor Create(AOwner: TComponent); override;
        destructor  Destroy; override;
        procedure DesigningChanged(aValue: Boolean); virtual;
        procedure ChangeDesigning(aValue: Boolean); virtual;
        function ClientToClient(Source: TControl; const Point: TPoint): TPoint;
        function BevelExtend: Integer;
        function BeveledRect: TRect;
        function ScreenRect(aRect: TRect): TRect;
        property Canvas;
        property Width;
        property Height;
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
        {$ENDIF}
    end;
    {$ENDIF}
    {$IFNDEF BUILD_ACTIVEX}
    {-- TMMCommonDialog -------------------------------------------------------}
    TMMCommonDialog = class(TCommonDialog)
    private
        {$IFDEF USE_ABOUT}
        FAbout: TMMAboutBox;
        {$ENDIF}
    published
        {$IFDEF USE_ABOUT}
        property About: TMMAboutBox read FAbout write FAbout stored False;
        {$ENDIF}
    end;
    {$ELSE}
    TMMCommonDialog = class(TMMNonVisualComponent)
    private
        FCtl3D: Boolean;
    protected
        function TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool; virtual;
    public
        constructor Create(AOwner: TComponent); override;
        function  Execute: Boolean; virtual; abstract;
    published
        property Ctl3D: Boolean read FCtl3D write FCtl3D default True;
    end;
    {$ENDIF}
{$I MMCONST.INC}
function  LoadResStr(const ResID: Word): String;
{$I MMCURSOR.INC}
function  LoadResCursor(const ResID: Word): HCURSOR;
{$I MMICON.INC}
function  LoadResIcon(const ResID: WORD): HICON;
function InheritsFromEx(Instance: TObject; AClass: TClass): Boolean;
function DeviceIdToIdent(Id: LongInt; var S: string): Boolean;
function IdentToDeviceId(const S: string; var Id: LongInt): Boolean;
implementation
uses
    MMUtils;
    
{==============================================================================}
{$IFDEF BUILD_ACTIVEX}
function InheritsFromEx(Instance: TObject; AClass: TClass): Boolean;
asm
  push esi
  push edi
  test eax,eax
  jz @@x
  cld
  sub ecx, ecx
  mov eax, [eax]
  mov edx, [edx].vmtClassName
@@loop:
  mov esi, [eax].vmtClassName
  mov cl, [esi]
  cmp cl, [edx]
  jne @@notyet
  inc ecx
  mov edi, edx
  repe cmpsb
  jz @@yes
@@notyet:
  call TObject.ClassParent
  jnz @@loop
  jmp @@x
@@yes:
  mov al, 1
@@x:
  pop edi
  pop esi
end;
{$ELSE}
function InheritsFromEx(Instance: TObject; AClass: TClass): Boolean;
begin
   Result := Instance.InheritsFrom(AClass)
end;
{$ENDIF}
{==============================================================================}
function LoadResStr(const ResID: Word): String;
begin
   Result := LoadStr(IDS_BASE + ResID);
end;
{==============================================================================}
function LoadResCursor(const ResID: Word): HCursor;
begin
   Result := LoadCursor(HInstance, PChar(crsBase + ResID));
end;
{==============================================================================}
function LoadResIcon(const ResID: Word): HIcon;
begin
   Result := LoadIcon(HInstance, PChar(icoBase + ResID));
end;
{$IFDEF WIN32}
{== TMMCriticalSection ========================================================}
procedure TMMCriticalSection.Acquire;
begin
   InterlockedIncrement(FlockCount);
   inherited;
end;
{-- TMMCriticalSection --------------------------------------------------------}
procedure TMMCriticalSection.Release;
begin
   inherited;
   InterlockedDecrement(FlockCount);
end;
{-- TMMCriticalSection --------------------------------------------------------}
function TMMCriticalSection.TryEnter: Boolean;
begin
   Result := FLockCount = 0;
   if Result then Enter;
end;
const
  Priorities: array [TThreadPriority] of Integer =
      (THREAD_PRIORITY_IDLE, THREAD_PRIORITY_LOWEST,
       THREAD_PRIORITY_BELOW_NORMAL, THREAD_PRIORITY_NORMAL,
       THREAD_PRIORITY_ABOVE_NORMAL, THREAD_PRIORITY_HIGHEST,
       THREAD_PRIORITY_TIME_CRITICAL);
{== TMMThreadEx ===============================================================}
procedure TMMThreadEx.SetPriority(Value: TThreadPriority);
begin
   MMSetThreadPriority(Handle, Priorities[Value]);
end;
{-- TMMThreadEx ---------------------------------------------------------------}
function TMMThreadEx.GetPriority: TThreadPriority;
begin
   Result := inherited Priority;
end;
{$ENDIF}
{== TMMObject =================================================================}
procedure TMMObject.BeginUpdate;
begin
   if FUpdateCount = 0 then SetUpdateState(True);
   inc(FUpdateCount);
end;
{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.EndUpdate;
begin
   dec(FUpdateCount);
   if FUpdateCount = 0 then SetUpdateState(False);
end;
{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.SetUpdateState(Updating: Boolean);
begin
  if Updating then Changing else Changed;
end;
{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.Changing;
begin
   if (FUpdateCount = 0) and Assigned(FOnChanging) then FOnChanging(Self);
end;
{-- TMMObject -----------------------------------------------------------------}
procedure TMMObject.Changed;
begin
   if (FUpdateCount = 0) and Assigned(FOnChange) then FOnChange(Self);
end;
{== TMMBevel ==================================================================}
constructor TMMBevel.Create;
begin
   inherited Create;
   FBevelInner      := bvNone;
   FBevelOuter      := bvLowered;
   FBevelInnerWidth := 1;
   FBevelOuterWidth := 1;
   FBorderStyle     := bsNone;
   FBorderWidth     := 0;
   FBorderSpace     := 0;
   FBorderColor     := clBtnFace;
   FBorderSpaceColor:= clBlack;
   FOuterLightColor := clBtnHighlight;
   FOuterShadowColor:= clBtnShadow;
   FInnerLightColor := clBtnHighlight;
   FInnerShadowColor:= clBtnShadow;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.Assign(Source: TPersistent);
begin
   if (Source is TMMBevel) and (Source <> Self) then
   begin
      BeginUpdate;
      try
         BevelInner      := TMMBevel(Source).BevelInner;
         BevelOuter      := TMMBevel(Source).BevelOuter;
         BevelInnerWidth := TMMBevel(Source).BevelInnerWidth;
         BevelOuterWidth := TMMBevel(Source).BevelOuterWidth;
         BorderStyle     := TMMBevel(Source).BorderStyle;
         BorderWidth     := TMMBevel(Source).BorderWidth;
         BorderSpace     := TMMBevel(Source).BorderSpace;
         BorderColor     := TMMBevel(Source).BorderColor;
         BorderSpaceColor:= TMMBevel(Source).BorderSpaceColor;
         OuterLightColor := TMMBevel(Source).OuterLightColor;
         OuterShadowColor:= TMMBevel(Source).OuterShadowColor;
         InnerLightColor := TMMBevel(Source).InnerLightColor;
         InnerShadowColor:= TMMBevel(Source).InnerShadowColor;
      finally
         EndUpdate;
      end;
   end
   else inherited assign(Source);
end;
{-- TMMBevel ------------------------------------------------------------------}
function TMMBevel.GetBevelExtend: Integer;
begin
   Result := FBorderWidth + FBorderSpace;
   if (FBevelOuter <> bvNone) then inc(Result, FBevelOuterWidth);
   if (FBevelInner <> bvNone) then inc(Result, FBevelInnerWidth);
   if (FBorderStyle <> bsNone) then inc(Result);
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelInner(Value: TPanelBevel);
begin
   if (Value <> FBevelInner) then
   begin
      FBevelInner := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelOuter(Value: TPanelBevel);
begin
   if (Value <> FBevelOuter) then
   begin
      FBevelOuter := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelInnerWidth(Value: TBevelWidth);
begin
   if (Value <> FBevelInnerWidth) then
   begin
      FBevelInnerWidth := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBevelOuterWidth(Value: TBevelWidth);
begin
   if (Value <> FBevelOuterWidth) then
   begin
      FBevelOuterWidth := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderStyle(Value: TBorderStyle);
begin
   if (Value <> FBorderStyle) then
   begin
      FBorderStyle := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderWidth(Value: TBorderWidth);
begin
   if (Value <> FBorderWidth) then
   begin
      FBorderWidth := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetBorderSpace(Value: TBorderWidth);
begin
   if (Value <> FBorderSpace) then
   begin
      FBorderSpace := Value;
      Changed;
   end;
end;
{-- TMMBevel ------------------------------------------------------------------}
procedure TMMBevel.SetColors(Index:Integer; Value: TColor);
begin
   case Index of
     0: if FBorderColor = Value then exit else FBorderColor := Value;
     1: if FBorderSpaceColor = Value then exit else FBorderSpaceColor := Value;
     2: if FInnerLightColor = Value then exit else FInnerLightColor := Value;
     3: if FInnerShadowColor = Value then exit else FInnerShadowColor := Value;
     4: if FOuterLightColor = Value then exit else FOuterLightColor := Value;
     5: if FOuterShadowColor = Value then exit else FOuterShadowColor := Value;
   end;
   Changed;
end;
{-- TMMBevel ------------------------------------------------------------------}
function TMMBevel.PaintBevel(Canvas: TCanvas; FrameRect: TRect; Fill: Boolean): TRect;
begin
   if (FBorderStyle = bsSingle) then
      Frame3D(Canvas, FrameRect, clWindowFrame, clWindowFrame, 1);
   if (FBevelOuter = bvLowered) then
      Frame3D(Canvas, FrameRect, OuterShadowColor, OuterLightColor, FBevelOuterWidth)
   else if (FBevelOuter = bvRaised) then
      Frame3D(Canvas, FrameRect, OuterLightColor, OuterShadowColor, FBevelOuterWidth);
   if Fill then
      Frame3D(Canvas, FrameRect, FBorderColor, FBorderColor, FBorderWidth)
   else
      InflateRect(FrameRect, -FBorderWidth, -FBorderWidth);
   if (FBevelInner = bvLowered) then
      Frame3D(Canvas, FrameRect, InnerShadowColor, InnerLightColor, FBevelInnerWidth)
   else if (FBevelInner = bvRaised) then
      Frame3D(Canvas, FrameRect, InnerLightColor, InnerShadowColor, FBevelInnerWidth);
   if (FBorderSpace <> 0) then
      Frame3D(Canvas, FrameRect, FBorderSpaceColor, FBorderSpaceColor, FBorderSpace);
   Result := FrameRect;
end;
{== TMMComponent ==============================================================}
procedure TMMComponent.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMComponent --------------------------------------------------------------}
procedure TMMComponent.ChangeDesigning(aValue: Boolean);
begin
   SetDesigning(aValue);
end;
{$IFDEF BUILD_ACTIVEX}
{== TMMAXControl ==============================================================}
procedure TMMAXControl.SetSelected(aValue: Boolean);
begin
   if (aValue <> FSelected) then
   begin
      FSelected := aValue;
      Refresh;
   end;
end;
{== TMMNonVisualComponent =====================================================}
constructor TMMNonVisualComponent.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   { !!! set DesignMode as default because many constructors check for the flag !!! }
{$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
{$ENDIF}
   Width := defWidth;
   Height:= defHeight;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  if csDesigning in ComponentState then
    inherited SetBounds(ALeft, ATop, defWidth, defHeight)
  else
    inherited SetBounds(ALeft, ATop, 0, 0)
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMNonVisualComponent.Paint;
var
   R: TRect;
   Bitmap: TBitmap;
   TransColor: TColor;
begin
   if (csNoDesignVisible in ControlStyle) then exit;
   //BringToFront;
   SetBounds(Left, Top, defWidth, defHeight);
   R := ClientRect;
   Frame3D(Canvas, R, clWhite, clBlack, 1);
   Frame3D(Canvas, R, clBtnFace, clGray, 1);
    // Paint like button no matter what Color property is
   Canvas.Brush.Color := clBtnFace;
   Canvas.FillRect(R);
   Bitmap := TBitmap.Create;
   try
      Bitmap.Handle := LoadBitmap(hInstance, PChar(UpperCase(ClassName)+'_X'));
      if (Bitmap.Handle = 0) then
          Bitmap.Handle := LoadBitmap(hInstance, PChar(UpperCase(ClassName)));
      if (Bitmap.Handle = 0) then
          Bitmap.Handle := LoadBitmap(hInstance, PChar(ToolBoxImageID));
      InflateRect(R, -((R.Right - R.Left) - Bitmap.Width) div 2,
                     -((R.Bottom - R.Top) - Bitmap.Height) div 2);
      TransColor := Bitmap.Canvas.Pixels[0,Bitmap.Height-1];
      Canvas.Brush.Color:= clBtnFace;
      Canvas.BrushCopy(R, Bitmap,
                       Rect(0, 0, Bitmap.Width, Bitmap.Height),
                       TransColor);
      if Selected then
      begin
         Canvas.Brush.Style := bsClear;
         Canvas.Pen.Color   := clRed;
         Canvas.Rectangle(0, 0, Width, Height);
         Canvas.Brush.Style := bsSolid;
      end;
   finally
      Bitmap.Free;
   end;
end;
{$ENDIF}
{== TMMWinControl =============================================================}
constructor TMMWinControl.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   {$ENDIF}
   if ComponentRegistered(InitCode, Self, ClassName) <> 0 then
      RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMWinControl -------------------------------------------------------------}
function TMMWinControl.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;
{-- TMMWinControl -------------------------------------------------------------}
procedure TMMWinControl.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMWinControl -------------------------------------------------------------}
procedure TMMWinControl.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
   { update visible state }
   UpdateControlState;
end;
{== TMMCustomControl ==========================================================}
constructor TMMCustomControl.Create(aOwner:TComponent);
begin
   inherited Create(aOwner);
   ControlStyle := ControlStyle + [csOpaque];
   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   Color  := clBtnFace;
   {$ENDIF}
   FBevel := TMMBevel.Create;
   FBevel.OnChange := BevelChanged;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMCustomControl ----------------------------------------------------------}
destructor TMMCustomControl.Destroy;
begin
   FBevel.OnChange := Nil;
   FBevel.Free;
   inherited Destroy;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
   { update visible state }
   UpdateControlState;
end;
{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.BevelChanged(Sender: TObject);
begin
   Changed;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.Changed;
begin
   Invalidate;
end;
{-- TMMCustomControl ----------------------------------------------------------}
Procedure TMMCustomControl.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;
{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.BevelExtend: Integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;
{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;
{-- TMMCustomControl ----------------------------------------------------------}
function TMMCustomControl.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClienttoScreen(Point(Left,Top));
      Result.BottomRight := ClienttoScreen(Point(Right,Bottom));
   end;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.Paint;
Var
   aRect: TRect;
begin
   { draw the Bevel and fill the area }
   aRect := FBevel.PaintBevel(Canvas, ClientRect, True);
   {$IFDEF BUILD_ACTIVEX}
   if not Transparent then
   {$ENDIF}
   with Canvas do
   begin
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(aRect);
   end;
end;
{$IFDEF BUILD_ACTIVEX}
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.SetTransparent(aValue: Boolean);
begin
   if (aValue <> FTransparent) then
   begin
      FTransparent := aValue;
      if FTransparent
        then ControlStyle := ControlStyle - [csOpaque]
        else ControlStyle := ControlStyle + [csOpaque];
      if HandleAllocated then ReCreateWnd;
   end;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.WMEraseBkgnd;
begin
   if Transparent then
      Message.Result := 1
   else
      inherited;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.WMWindowPosChanging;
begin
   inherited;
   if Transparent then Invalidate;
end;
{-- TMMCustomControl ----------------------------------------------------------}
procedure TMMCustomControl.CreateParams;
begin
   inherited;
   if Transparent then
      Params.ExStyle := Params.ExStyle or WS_EX_TRANSPARENT;
end;
{$ENDIF}
{== TMMCustomPanel ============================================================}
constructor TMMCustomPanel.Create(aOwner: TComponent);
begin
   inherited Create(aOwner);
   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   {$ENDIF}
   FOnPaint := nil;
   { make sure the inherited values are not used by aligncontrols !! }
   BorderWidth := 0;
   BevelOuter := bvNone;
   BevelInner := bvNone;
   FBevel := TMMBevel.Create;
   FBevel.OnChange := BevelChanged;
   FFillBevel := True;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMCustomPanel ------------------------------------------------------------}
destructor TMMCustomPanel.Destroy;
begin
   FBevel.OnChange := Nil;
   FBevel.Free;
   inherited Destroy;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
   { update visible state }
   UpdateControlState;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;
{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.SetFillBevel(aValue: Boolean);
begin
   if (aValue <> FFillBevel) then
   begin
      FFillBevel := aValue;
      Invalidate;
   end;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.BevelChanged(Sender: TObject);
begin
   ReAlign;
   Changed;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.AlignControls(aControl: TControl; Var Rect: TRect);
begin
   if (FBevel <> nil) then
      InflateRect(Rect, -FBevel.BevelExtend, -FBevel.BevelExtend);
   inherited AlignControls(aControl, Rect);
end;
{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.BevelExtend: integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;
{-- TMMCustomPanel ------------------------------------------------------------}
Procedure TMMCustomPanel.Changed;
begin
   Invalidate;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClientToScreen(Point(Left,Top));
      Result.BottomRight := ClientToScreen(Point(Right,Bottom));
   end;
end;
{-- TMMCustomPanel ------------------------------------------------------------}
function TMMCustomPanel.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;
{-- TMMCustomPanel ------------------------------------------------------------}
procedure TMMCustomPanel.Paint;
Const
   Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
Var
   aRect: TRect;
   FontHeight: Integer;
   Text: PChar;
begin
     if assigned(FOnPaint) then FOnPaint(Self)
     else
     begin
        { draw the Bevel }
        aRect := FBevel.PaintBevel(Canvas, ClientRect, FFillBevel);
        with Canvas do
        begin
           if assigned(FOnFill) then FOnFill(Self,Canvas,aRect)
           else
           begin
              Brush.Color := Color;
              Brush.Style := bsSolid;
              FillRect(aRect);
           end;
           if Caption <> '' then
           begin
              Text := StrAlloc(Length(Caption)+1);
              try
                 StrPCopy(Text, Caption);
                 Brush.Style := bsClear;
                 Font := Self.Font;
                 FontHeight := TextHeight('W');
                 with aRect do
                 begin
                    Top := ((Bottom + Top) - FontHeight) shr 1;
                    Bottom := Top + FontHeight;
                 end;
                 DrawText(Handle, Text, StrLen(Text), aRect, (DT_EXPANDTABS or
                          DT_VCENTER) or Alignments[Alignment]);
              finally
                 StrDispose(Text);
              end;
           end;
        end;
     end;
end;
{$IFNDEF BUILD_ACTIVEX}
{== TMMGraphicControl =========================================================}
constructor TMMGraphicControl.Create(aOwner:TComponent);
begin
   inherited Create(aOwner);
   { !!! set DesignMode as default because many constructors check for the flag !!! }
   {$IFDEF BUILD_ACTIVEX}
   SetDesigning(True);
   {$ENDIF}
   ControlStyle := ControlStyle + [csOpaque];
   FBevel := TMMBevel.Create;
   FBevel.OnChange := BevelChanged;
   FTransparent := False;
   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMGraphicControl ---------------------------------------------------------}
destructor TMMGraphicControl.Destroy;
begin
   FBevel.OnChange := Nil;
   FBevel.Free;
   inherited Destroy;
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMGraphicControl.DesigningChanged(aValue: Boolean);
begin
   if aValue <> (csDesigning in ComponentState) then
      ChangeDesigning(aValue);
end;
{-- TMMNonVisualComponent -----------------------------------------------------}
procedure TMMGraphicControl.ChangeDesigning(aValue: Boolean);
begin
   { !!! overwrite this methode to re-initialize the component if we are not in DesignMode !!! }
   SetDesigning(aValue);
end;
{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.ClientToClient(Source: TControl; const Point: TPoint): TPoint;
begin
   Result := ScreenToClient(Source.ClientToScreen(Point));
end;
{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.BevelChanged(Sender: TObject);
begin
   Changed;
end;
{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.Changed;
begin
   Invalidate;
end;
{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.SetBevel(aValue: TMMBevel);
begin
   FBevel.Assign(aValue);
end;
{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.BevelExtend: Integer;
begin
   Result := 0;
   if (FBevel <> nil) then
       Result := FBevel.BevelExtend;
end;
{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.BeveledRect: TRect;
begin
   Result := Rect(0,0,Width,Height);
   InflateRect(Result, -BevelExtend, -BevelExtend);
end;
{-- TMMGraphicControl ---------------------------------------------------------}
function TMMGraphicControl.ScreenRect(aRect: TRect): TRect;
begin
   with aRect do
   begin
      Result.TopLeft := ClientToScreen(Point(Left,Top));
      Result.BottomRight := ClientToScreen(Point(Right,Bottom));
   end;
end;
{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.SetTransparent(aValue: Boolean);
begin
   if (aValue <> FTransparent) then
   begin
      FTransparent := aValue;
      if FTransparent then ControlStyle := ControlStyle - [csOpaque]
      else ControlStyle := ControlStyle + [csOpaque];
      Refresh;
   end;
end;
{-- TMMGraphicControl ---------------------------------------------------------}
procedure TMMGraphicControl.Paint;
Var
   aRect: TRect;
begin
   { draw the Bevel and fill the area }
   aRect := FBevel.PaintBevel(Canvas, ClientRect, True);
   if not FTransparent then
   with Canvas do
   begin
      Brush.Color := Color;
      Brush.Style := bsSolid;
      FillRect(aRect);
   end;
end;
{$ELSE}
{ TCommonDialog }
{== TMMCommonDialog ===========================================================}
constructor TMMCommonDialog.Create(aOwner: TComponent);
begin
  inherited Create(AOwner);
  FCtl3D := True;
  {$IFDEF BUILD_ACTIVEX}
  DesigningChanged(False);
  Visible := False;
  {$ENDIF}
  ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
  if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;
{-- TMMCommonDialog -----------------------------------------------------------}
function TMMCommonDialog.TaskModalDialog(DialogFunc: Pointer; var DialogData): Bool;
type
  TDialogFunc = function(var DialogData): Bool stdcall;
var
  ActiveWindow: HWnd;
  WindowList: Pointer;
begin
  ActiveWindow := GetActiveWindow;
  WindowList := DisableTaskWindows(0);
  try
    Result := TDialogFunc(DialogFunc)(DialogData);
  finally
    EnableTaskWindows(WindowList);
    SetActiveWindow(ActiveWindow);
  end;
end;
{$ENDIF}
{==============================================================================}
function DeviceIdToIdent(Id: LongInt; var S: string): Boolean;
begin
   Result := False;
   if Id = InvalidId then
      S := 'InvalidId'
   else if Id = MapperId then
      S := 'MapperId'
   else
      Exit;
   Result := True;
end;
{==============================================================================}
function IdentToDeviceId(const S: string; var Id: LongInt): Boolean;
begin
   Result := False;
   if CompareText(S,'InvalidId') = 0 then
      Id := InvalidId
   else if CompareText(S,'MapperId') = 0 then
      Id := MapperId
   else
      Exit;
   Result := True;
end;
{------------------------------------------------------------------------------}
procedure LoadCursors;
var
   i: integer;
begin
   for i := 1 to NumCursors do
       Screen.Cursors[crsBase+i]:= LoadResCursor(i);
end;
initialization
   LoadCursors;
   RegisterIntegerConsts(TypeInfo(TMMDeviceId),IdentToDeviceId,DeviceIdToIdent);
end.

						