mmobj.pas

一套及时通讯的原码

{========================================================================}
{=                (c) 1995-98 SwiftSoft Ronald Dittrich                 =}
{========================================================================}
{=                          All Rights Reserved                         =}
{========================================================================}
{=  D 01099 Dresden             = Fax.: [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: 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;