mmdesign.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: 12.08.98 - 13:14:05 $                                        =}
{========================================================================}
unit MMDesign;

{$I COMPILER.INC}

{.$DEFINE _MMDEBUG}

interface

uses
{$IFDEF WIN32}
  Windows,
{$ELSE}
  WinProcs,
  WinTypes,
{$ENDIF}

  SysUtils,
  Messages,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  ExtCtrls,
  StdCtrls,
  MMObj,
  MMHook,
  MMPanel;

type
  TCompRect = record
       Left  : integer;
       Top   : integer;
       Height: integer;
       Width : integer;
       Ok    : Boolean;
  end;

  TPropType     = (ptInput,ptOutput);
  TConnectCheck = function(C1, C2: TComponent): Boolean;
  TConnect      = procedure(C1, C2: TComponent);

  {-- TMMDesigner --------------------------------------------------------}
  TMMDesigner = class(TMMWndProcComponent)
  private
    FAutoUpdate     : Boolean;
    FActive         : Boolean;
    FUpdate         : Boolean;
    FVisible        : Boolean;
    FSound          : Boolean;
    FColor          : TColor;
    FLineWidth      : integer;
    FMargin         : integer;
    FParentForm     : TForm;
    FParentComponent: TComponent;
    FTimer          : TTimer;
    FPaintOk        : Boolean;
    FRuntimeHeight  : integer;
    FShowButton     : Boolean;
    FButtonDown     : Boolean;
    FButtonPressed  : Boolean;
    FProhibited     : TStringList;
    FAllowed        : TList;
    FPortList       : TList;
    FConnList       : TList;
    FValidLists     : Boolean;
    FRebuilding     : Boolean;

    procedure SetActive(aValue: Boolean);
    procedure SetUpdate(aValue: Boolean);
    procedure SetLineWidth(aValue: integer);
    procedure SetMargin(aValue: integer);
    procedure SetColor(aValue: TColor);
    procedure SetShowButton(aValue: Boolean);

    procedure DesignerFormPos;
    function  ButtonRect: TRect;
    function  InButton(pt: TPoint): Boolean;
    procedure PaintButton(Down: Boolean);
    procedure RefreshCaption;

    procedure SetPen(Color: TColor; Width:integer; Style: TPenStyle);
    procedure TimerAction(Sender:TObject);
    procedure RefreshForm(ControlsOk, ComponentsOk: Boolean);
    procedure GetComponentPos(Comp: TComponent; var CompRect: TCompRect);
    procedure DrawConnection(CompRect1,CompRect2: TCompRect;ArrowOk: Boolean);
    procedure DrawPorts(Comp: TComponent; InPort,OutPort: Boolean);
    procedure InitDesigner;

  protected
    procedure ChangeDesigning(aValue: Boolean); override;
    procedure Loaded; override;
    procedure HookWndProc(var Message: TMessage); override;

    function  HasInput(C: TComponent): Boolean;
    function  HasOutput(C: TComponent): Boolean;
    function  FindConnectProp(C1,C2: TComponent): Integer;
    function  HasPotentialInput(C: TComponent): Boolean;
    function  HasPotentialOutput(C: TComponent): Boolean;
    function  CheckInput(C: TComponent; Pt: TPoint; var R: TRect): Boolean;
    function  CheckOutput(C: TComponent; Pt: TPoint; var R: TRect): Boolean;
    function  FindProp(Pt: TPropType; CFrom: TComponent; CTo: TComponent; StartFrom: Integer): Integer;
    function  HasException(CompFrom: TComponent; CompTo: TComponent;
                           Index: Integer): Boolean;
    function  FindRef(PropType: TPropType;C: TComponent;StartFrom: Integer): Integer;
    function  FindRefs(PropType:TPropType;R,C:TComponent;StartFrom:Integer):Integer;
    function  RemoveRef(C: TComponent; PropType: TPropType): Boolean;
    function  RemoveRefs(C: TComponent; PropType: TPropType): Boolean;
    procedure GetConnected(C: TComponent; List: TList);
    function  Allowed: TList;
    procedure RebuildLists;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override ;

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

    function  FindTarget(Form: TForm; Wnd: HWND; var Pt: TPoint; var TargetType: TPropType; var R: TRect): TComponent;
    function  RemoveInput(C: TComponent): Boolean;
    function  RemoveOutput(C: TComponent): Boolean;
    procedure DrawPaintBox;
    procedure BeepSound(aValue: Cardinal);
    function  CanConnect(C1,C2: TComponent): Boolean;
    procedure Connect(C1,C2: TComponent);

    property  ParentForm: TForm read FParentForm;
    property  ParentComponent: TComponent read FParentComponent;
    property  Visible: Boolean read FVisible;

  published
    property  Active: Boolean read FActive write SetActive default True;
    property  Color: TColor read FColor write SetColor default clRed;
    property  LineWidth: integer read FLineWidth write SetLineWidth default 1;
    property  Margin: integer read FMargin write SetMargin default 6;
    property  AutoUpdate: Boolean read FAutoUpdate write FAutoUpdate default True;
    property  Update: Boolean read FUpdate write SetUpdate;
    property  Sound: Boolean read FSound write FSound default True;
    property  ShowButton: Boolean read FShowButton write SetShowButton default False;
    property  RuntimeHeight: integer read FRuntimeHeight write FRuntimeHeight;
  end;

  {-- TMMDesignerForm ----------------------------------------------------}
  TMMDesignerForm = class(TForm)
    MMPanel1: TMMPanel;
    btnClose: TButton;
    ckbActive: TCheckBox;
    ckbAuto: TCheckBox;
    ckbSound: TCheckBox;
    btnHeight: TButton;
    GroupBox: TListBox;
    Label1: TLabel;
    btnAll: TButton;
    btnNone: TButton;
    Bevel1: TBevel;
    Bevel2: TBevel;
    procedure CheckBoxClick(Sender: TObject);
    procedure FormShow(Sender: TObject);
    procedure btnHeightClick(Sender: TObject);
    procedure FormHide(Sender: TObject);
    procedure btnAllClick(Sender: TObject);
    procedure btnNoneClick(Sender: TObject);
  public
    Designer: TMMDesigner;
  end;

  {-- TPropRec ----------------------------------------------------------------}
  TPropRec = class(TObject)
    PropType    : TPropType;
    PropGroup   : string;
    ClassFrom   : TClass;
    PropName    : string;
    ClassTo     : TClass;
    CheckProc   : TConnectCheck;

    constructor Create(APropType: TPropType; const APropGroup: string;
                       AClassFrom: TClass;
                       const APropName: string; AClassTo: TClass;
                       ACheckProc: TConnectCheck);
  end;

var
   DesignerForm: TMMDesignerForm;

var
   _FindDesignerForWindow: function(Wnd: HWND): TMMDesigner = nil;
   _AddDesigner          : procedure(Designer: TMMDesigner) = nil;
   _RemoveDesigner       : procedure(Designer: TMMDesigner) = nil;
   _RedrawTrack          : procedure(Show: Boolean);

const
   Griff = 5;
   ComponentWidth  = 28;
   ComponentHeight = 28;

const
   ControlList : TList   = nil;
   CreateCount : integer = 0;
   GetMsgHook  : HHook   = 0;
   PaintCount  : integer = 0;
   PaintOk     : Boolean = False;
   Dragging    : Boolean = False;
   Deconnect   : Boolean = False;
   Adjusting   : Boolean = False;
   PropList     : TList  = nil;
   ExcPropList  : TList  = nil;

var
   DragDesigner: TMMDesigner;
   DragOrigin  : TPoint;
   DragPoint   : TPoint;
   DragRect    : TRect;
   DragInput   : Boolean;

   DragSource  : TComponent;
   DragDest    : TComponent;

   TrackVisible: Boolean;
   DesignBitmap: HBITMAP;
   BitmapWidth : integer;
   BitmapHeight: integer;

procedure DoneDragging;

{========================================================================}
implementation

{$R *.DFM}

uses
    Consts,
    TabNotBk,
    TypInfo,
    MMUtils
    {$IFDEF WIN32}
    ,ComCtrls
    {$ENDIF}
    {$IFDEF _MMDEBUG}
    ,MMDebug
    {$ENDIF};

{== TPropRec ============================================================}
constructor TPropRec.Create(APropType: TPropType; const APropGroup: string;
                            AClassFrom: TClass;
                            const APropName: string; AClassTo: TClass;
                            ACheckProc: TConnectCheck);
begin
   inherited Create;

   PropType    := APropType;
   PropGroup   := APropGroup;
   ClassFrom   := AClassFrom;
   PropName    := APropName;
   ClassTo     := AClassTo;
   CheckProc   := ACheckProc;
end;

{------------------------------------------------------------------------}
function IsCompiling: Boolean;
begin
   Result := FindWindow('TProgressForm',nil) <> 0;
end;

{------------------------------------------------------------------------}
function LeftGriff(C: TComponent): TRect;
begin
   if (C is TControl) then
   with (C as TControl) do
   begin
      Result.Left   := Left - Griff div 2;
      Result.Top    := (Top + Height div 2) - Griff div 2 - (Height+1) mod 2;
   end
   else
   begin
      Result.Left   := LoWord(C.DesignInfo) - Griff div 2;
      Result.Top    := HiWord(C.DesignInfo) + (ComponentWidth div 2) - 1 - Griff div 2;
   end;
   Result.Right  := Result.Left + Griff;
   Result.Bottom := Result.Top + Griff;
end;

{------------------------------------------------------------------------}
function RightGriff(C: TComponent): TRect;
begin
   Result          := LeftGriff(C);
   Result.Left     := Result.Left + ComponentWidth - 1;
   Result.Right    := Result.Left + Griff;
end;

{------------------------------------------------------------------------}
function DesignerVisible(Designer: TMMDesigner): Boolean;
var
   L,T: integer;
begin
   Result := False;
   if (Designer <> nil) then
   with Designer do
   begin
      L:= LoWord(DesignInfo);
      T:= HiWord(DesignInfo);
      Result := (L < FParentForm.ClientWidth) and
                (T < FParentForm.ClientHeight);
   end;
end;

{------------------------------------------------------------------------}
function ControlVisible(AControl: TControl): Boolean;
begin
   if AControl is TForm then
   begin
      Result := True;
      Exit;
   end;

   if (AControl is TWinControl)
   {$IFDEF WIN32}
      and not (AControl is TTabSheet)
   {$ENDIF}
      and not (AControl is TPage) then
      Result := IsWindowVisible((AControl as TWinControl).Handle)
   else
      Result := AControl.Visible;

   if (AControl.Parent <> nil) then
       Result := Result and ControlVisible(AControl.Parent);
end;

{------------------------------------------------------------------------}
procedure DoneDragging;
begin
   if (DragDesigner <> nil) then
   with DragDesigner do
   if MMDesign.Dragging or Adjusting then
   begin
      _RedrawTrack(False);
      ClipCursor(nil);
      MMDesign.Dragging := False;
      Adjusting:= False;
   end;
end;

{------------------------------------------------------------------------}
function CheckPropAvail(C: TComponent; i: Integer; NeedCheck: Boolean): Boolean;
begin
   if NeedCheck then
      Result := GetPropInfo(C.ClassInfo,TPropRec(PropList[i]).PropName) <> nil
   else
      Result := True;
end;

{------------------------------------------------------------------------}
function GetPropValue(C: TComponent; i: Integer): TComponent;
begin
   Result := TComponent(GetOrdProp(C,GetPropInfo(C.ClassInfo,TPropRec(PropList[i]).PropName)));
end;

{------------------------------------------------------------------------}
procedure SetPropValue(C: TComponent; i: Integer; Value: TComponent);
begin
   SetOrdProp(C,GetPropInfo(C.ClassInfo,TPropRec(PropList[i]).PropName),LongInt(Value));
end;

{== TMMDesigner =========================================================}
constructor TMMDesigner.Create(AOwner: TComponent);
var
   CompOwner: TComponent;

begin
   inherited Create(AOwner);

   {$IFDEF WIN32}
   if (Owner is TDataModule) then
   begin
      CompOwner := Owner.Owner;
   end
   else {$ENDIF} CompOwner := Owner;

{  TODO: DataModules currently not supported !!!        }
{  if (CompOwner <> nil) and (CompOwner is TForm) then  }
   if (Owner <> nil) and (Owner is TForm) then
   begin
      FParentForm := CompOwner as TForm;

      FParentComponent := Owner;

      {$IFDEF BUILD_ACTIVEX}
      ParentWindow := TWinControl(aOwner).Handle;
      {$ENDIF}

      if assigned(_FindDesignerForWindow) then
         if _FindDesignerForWindow(FParentForm.Handle) <> nil then
            raise Exception.Create('Only one Designer is allowed per Form');

      FActive := True;
      FAutoUpdate := True;
      FUpdate := False;
      FSound := True;
      FColor := clRed;
      FLineWidth := 1;
      FMargin := 6;
      RuntimeHeight := -1;
      FShowButton := False;
      FButtonDown := False;
      FButtonPressed:= False;

      InitDesigner;
   end
   else FormOk := False;

   ErrorCode := ComponentRegistered(InitCode, Self, ClassName);
   if (ErrorCode <> 0) then RegisterFailed(InitCode, Self , ClassName);
end;

{-- TMMDesigner ---------------------------------------------------------}
destructor TMMDesigner.Destroy;
begin
   if FormOK and (FTimer <> nil) then
   begin
      { Timer may be nil because of MessageDlg instead of raise }
      FTimer.OnTimer := nil;
      FTimer.Free;

      { unhook the parent Forms WndProc }
      UnHookOwner;

      if assigned(_RemoveDesigner) then
         _RemoveDesigner(Self);