Unit CustomIf; Interface {$WARN UNSAFE_CAST OFF} {$WARN UNSAFE_TYPE OFF} {$WARN UNSAFE_CODE OFF} Uses Windows, Messages, SysUtils, Math, Classes, Contnrs, Graphics, Controls, Forms, Dialogs, ExtCtrls, Buttons, StdCtrls, ComCtrls, ClipBrd, Utils, Globals; Const UM_CONNECTIONADD = WM_USER + 0; UM_CONNECTIONREMOVE = WM_USER + 1; UM_COLORCHANGE = WM_USER + 2; UM_HIGHLIGHT = WM_USER + 3; Const ColorDisplay = $00917B00; // Default BackgroundColor for TDisplay. a bit clTeal like. Type // Exceptions ECustomIf = Class( Exception); ECorruptPatch = Class( ECustomIf); ENoDuplicates = Class( ECustomIf); TConnectOp = ( coConnect, coDisconnect ); TConnector = Class; TOnValueChange = Procedure( aSender: TObject; aValue: TValue; Const aRepresentation: String) Of Object; TOnConnectionChange = Procedure( aSender: TObject; aConnectOp: TConnectOp; aSrc, aDst: TConnector; Var DoIt: Boolean) Of Object; TClicker = Class( TSpeedButton) // Repeating speed button, semi flat ... Private FRepeatTimer : TTimer; FRepeatCount : Integer; FCanRepeat : Boolean; FMouseDown : Boolean; FShowFocus : Boolean; FBitmap : TBitmap; Private Procedure TimerExpired( aSender: TObject); Procedure SetShowFocus( aValue: Boolean); Private Property ShowFocus: Boolean Read FShowFocus Write SetShowFocus; Protected Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp ( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure AssignBitmap( aBitmap: TBitmap); Public Constructor Create( anOwner: TComponent); Override; Destructor Destroy; Override; Procedure Click; Override; Public Property CanRepeat: Boolean Read FCanRepeat Write FCanRepeat Default True; End; TDisplay = Class; TKnob = class( TCustomControl) // A clavia style rotary knob Private FMinValue : TValue; FMaxValue : TValue; FValue : TValue; FStepSize : TValue; FOnValueChange : TOnValueChange; FDownClicker : TClicker; FUpClicker : TClicker; FMouseDown : Boolean; FBitmap : TBitmap; FDisplayFormat : String; FUseNoteName : Boolean; FMouseInControl: Boolean; FTransparent : Boolean; FDisplay : TDisplay; procedure WMSetFocus ( Var Message: TWMSetFocus ); Message WM_SETFOCUS; procedure WMKillFocus ( Var Message: TWMKillFocus ); Message WM_KILLFOCUS; procedure WMGetDlgCode( Var Message: TWMGetDlgCode); Message WM_GETDLGCODE; procedure CMMouseEnter( Var Message: TMessage); Message CM_MOUSEENTER; procedure CMMouseLeave( Var Message: TMessage); Message CM_MOUSELEAVE; Function CreateClicker( aLeft, aTop: Integer; aNotifyEvent: TNotifyEvent; aBitmap: TBitmap): TClicker; Procedure OnDownClick( aSender: TObject); Procedure OnUpClick ( aSender: TObject); Function GetAsString: String; Procedure NotifyEnvironment; Private Procedure SetMinValue ( aValue: TValue); Procedure SetMaxValue ( aValue: TValue); Procedure SetValue ( aValue: TValue); Procedure SetStepSize ( aValue: TValue); Procedure SetDisplayFormat( Const aValue: String); Procedure SetUseNoteName ( aValue: Boolean); Procedure SetTransparent ( aValue: Boolean); Procedure SetDisplay ( aValue: TDisplay); Procedure SetOnValueChange( aValue: TOnValueChange); Private Function CenterPoint: TPoint; Function CreateRgn: HRGN; Procedure BeginMove ( aPoint: TPoint); Virtual; Procedure EndMove ( aPoint: TPoint); Virtual; Procedure UpdateMove( aPoint: TPoint); Virtual; Protected Procedure Paint; Override; Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp ( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseMove( Shift: TShiftState; X, Y: Integer); Override; procedure KeyDown( Var Key: Word; Shift: TShiftState); Override; Procedure AssignBitmap; Virtual; Procedure Loaded; Override; Public Constructor Create( anOwner: TComponent); Override; Public Property AsString: String Read GetAsString; Published Property MinValue : TValue Read FMinValue Write SetMinValue; Property MaxValue : TValue Read FMaxValue Write SetMaxValue; Property Value : TValue Read FValue Write SetValue; Property StepSize : TValue Read FStepSize Write SetStepSize; Property DisplayFormat: String Read FDisplayFormat Write SetDisplayFormat; Property UseNoteName : Boolean Read FUseNoteName Write SetUseNoteName; Property Transparent : Boolean Read FTransparent Write SetTransparent; Property Color; Property TabOrder; Property TabStop; Property Display : TDisplay Read FDisplay Write SetDisplay; Property OnValueChange: TOnValueChange Read FOnValueChange Write SetOnValueChange; end; TSmallKnob = Class( TKnob) // just smaller than TKnob Protected Procedure AssignBitmap; Override; End; TDisplay = Class( TStaticText) // can be linked to TKnobs for auto updates Protected Procedure WMNCHitTest( Var aMessage: TWMNCHitTest); Message WM_NCHITTEST; Procedure Loaded; Override; Public Constructor Create( anOwner: TComponent); Override; Published Property Color Default ColorDisplay; Property Width Default 33; Property Height Default 15; Property AutoSize Default False; Property BorderStyle Default sbsSunken; End; TIndicator = Class( TGraphicControl) // an LED Private FActive : Boolean; FActiveBm : TBitmap; FInActiveBm : TBitmap; Private Procedure SetActive ( aValue: Boolean); Procedure SetBitmapActive ( aValue: TBitmap); Procedure SetBitmapInactive( aValue: TBitmap); Protected Procedure AssignBitmaps; Procedure Paint; Override; Public Constructor Create( anOwner: TComponent); Override; Public Property BitnapActive : TBitmap Read FActiveBm Write SetBitmapActive; Property BitnapInactive : TBitmap Read FInactiveBm Write SetBitmapInactive; Published Property Active : Boolean Read FActive Write SetActive; End; TConnector = Class( TGraphicControl) // To connect wires to Private FBitmap : TBitmap; FDoubleClicked : Boolean; FMouseDown : Boolean; FConnected : Boolean; // True when at least on connection exists FHighLight : Boolean; // Highlighted connections FLinks : TList; // Connections from this connector FBlockRecur : Boolean; // Flag to block unwanted recursion FWireColor : TColor; Private Procedure SetConnected( aValue: Boolean); Procedure SetHighLight( aValue: Boolean); Procedure SetWireColor( aValue: TColor ); Private Procedure AddLink ( aConnector: TConnector); Procedure DelLink ( aConnector: TConnector); Procedure AddBackLink( aConnector: TConnector); Procedure MoveLinksTo( aConnector: TConnector); Procedure DelLinks; Procedure DelBackLink( aConnector: TConnector); Function HaslinkTo ( aConnector: TConnector): Boolean; Function FindConnector( aScreenPoint: TPoint): TConnector; Function CenterPoint: TPoint; Procedure DrawLine( X, Y: Integer); Procedure SendWireNotification( Msg: Cardinal; aConnector: TConnector); Procedure SendColorNotification( aColor: TColor); Procedure SendHighlightNotification; Protected Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp ( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseMove( Shift: TShiftState; X, Y: Integer); Override; Function FindOutput: TConnector; Function IsConnectedToOutput: Boolean; Function OutputColor: TColor; Function CanAccept( aSource: TConnector): Boolean; Procedure AssignBitmap; Virtual; Abstract; Procedure ConnectTo( aConnector: TConnector); Procedure DisConnect; Procedure Paint; Override; Protected Property HighLight: Boolean Read FHighLight Write SetHighLight; Public Constructor Create( anOwner: TComponent); Override; Destructor Destroy; Override; Public Property Connected : Boolean Read FConnected Write SetConnected; Published Property WireColor : TColor Read FWireColor Write SetWireColor Default clBlue; End; TInput = Class( TConnector) Protected Procedure AssignBitmap; Override; End; TOutput = Class( TConnector) Protected Procedure AssignBitmap; Override; End; TTextLabel = Class( TCustomLabel) // A small TLabel Protected Procedure DoDrawText( Var aRect: TRect; aFlags: Longint); Override; Public Constructor Create( anOwner: TComponent); Override; Published property Align; property Alignment; property Anchors; property AutoSize; property BiDiMode; property Caption; property Color; property Constraints; property DragCursor; property DragKind; property DragMode; property Enabled; property FocusControl; property Font; property ParentBiDiMode; property ParentColor; property ParentFont; property ParentShowHint; property PopupMenu; property ShowAccelChar; property ShowHint; property Transparent; property Layout; property Visible; property WordWrap; End; TEditLabel = Class; // forward decl. TLabelEditor = Class( TEdit) // The editor for the editable label Private FLabel : TEditLabel; procedure WMKillFocus( Var Message: TWMKillFocus ); Message WM_KILLFOCUS; Procedure Do_Exit ( aSender: TObject); Procedure Do_KeyDown( aSender: TObject; Var aKey: Word; aShift: TShiftState); Protected Procedure SetLabel( aLabel: TEditLabel); Public Constructor Create( anOwner: TComponent); Override; End; TEditLabel = Class( TTextLabel) // a label with a popup editor Protected Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Public Constructor Create( anOwner: TComponent); Override; End; TBox = Class( TBevel) Public Constructor Create( anOwner: TComponent); Override; Published Property Enabled Default False; End; TWire = Class Public FSource : TConnector; FDestination : TConnector; FHighlight : Boolean; FMarked : Boolean; Constructor Create( aSource, aDestination: TConnector); End; TCustomModule = Class; TCustomModuleClass = class of TCustomModule; TWireOverlay = Class( TCustomControl) Private FWires : TObjectList; // Responsibilty to maintain wires (connections) // is assumed by the TConnectors themself. // // The FWires list is really a cache, only // used to ease wire painting a little. // // It is maintained by the connectors theselves // that send their info to us through the // WirePanel (by means of UM_CONNEXTIONxx // and UM_HIGHLIGHT messages). The WirePanel // imforms us by calling the AddWire, DelWire // and Highlight methodes. // // All Wires are owned by FWires, so our destructor // will eventually destroy all dangling wires. // Nevertheless, TConnector still must, on destruction, // clean up the wires it is responsible for. FCurvedLines : Boolean; FWireThickness : Integer; FDefaultWireColor : TColor; Private procedure WMNCHitTest( Var aMessage: TWMNCHitTest); Message WM_NCHITTEST; Procedure MarkWires( aConnector: TConnector); Private Function GetWire ( anIndex: Integer): TWire; Function GetSource ( anIndex: Integer): TConnector; Function GetDestination ( anIndex: Integer): TConnector; Procedure SetCurvedLines ( aValue: Boolean ); Procedure SetWireThickNess( aValue: Integer ); Protected Procedure Paint; Override; Procedure PaintWire( aDC: HDC; aWire: TWire); Function FindWire ( aSource, aDestination: TConnector): Integer; Procedure AddWire ( aSource, aDestination: TConnector); Procedure DelWire ( aSource, aDestination: TConnector); Procedure Connect ( aSource, aDestination: TConnector); Procedure HandleHighlight; Procedure HandleColorChange( aSource: TConnector; aColor: TColor); Function WireCount: Integer; Public Constructor Create( anOwner: TComponent); Override; Destructor Destroy; Override; Procedure InvalidateWires; Dynamic; Procedure Disconnect( aConnector: TConnector); Public Property Wire [ anIndex: Integer]: TWire Read GetWire; Property Source [ anIndex: Integer]: TConnector Read GetSource; Property Destination[ anIndex: Integer]: TConnector Read GetDestination; Public Property CurvedLines : Boolean Read FCurvedLines Write SetCurvedLines Default True; Property WireThickness : Integer Read FWireThickness Write SetWireThickness NoDefault; Property DefaultWireColor : TColor Read FDefaultWireColor Write FDefaultWireColor Default clBlue; Published Property Left Stored False; Property Top Stored False; Property Width Stored False; Property Height Stored False; End; TUMConnectionChange = Packed Record Msg : Cardinal; Source : TConnector; Destination : TConnector; Result : LongInt; End; TUMColorChange = Packed Record Msg : Cardinal; Source : TConnector; Color : TColor; Result : LongInt; End; TUMConnectionAdd = TUMConnectionChange; TUMConnectionRemove = TUMConnectionChange; TUMHighlight = Packed Record Msg : Cardinal; NotUsed1 : LongInt; NotUsed2 : LongInt; Result : LongInt; End; TWirePanel = Class( TScrollingWinControl) // To contain modules + wire overlay. Private FMouseDown : Boolean; FWireOverlay : TWireOverlay; FModules : TList; FConnectionFixups : TStringList; FFilename : String; FSnapX : Integer; FSnapY : Integer; FSnapActive : Boolean; Private Procedure MarkWires( aConnector: TConnector); Procedure UMConnectionAdd ( Var aMessage: TUMConnectionAdd ); Message UM_CONNECTIONADD; Procedure UMConnectionRemove( Var aMessage: TUMConnectionRemove); Message UM_CONNECTIONREMOVE; Procedure UMColorChange ( Var aMessage: TUMColorChange ); Message UM_COLORCHANGE; Procedure UMHighlight ( Var aMessage: TUMHighlight ); Message UM_HIGHLIGHT; Private Function GetModule ( anIndex: Integer): TCustomModule; Function GetWire ( anIndex: Integer): TWire; Function GetSource ( anIndex: Integer): TConnector; Function GetDestination( anIndex: Integer): TConnector; Private Function GetCurvedLines : Boolean; Procedure SetCurvedLines ( aValue: Boolean); Function GetWireThickness : Integer; Procedure SetWireThickness ( aValue: Integer); Function GetDefaultWireColor: TColor; Procedure SetDefaultWireColor( aValue: TColor); Private Procedure ClearConnectionFixups; Procedure AddConnectionFixup( Const S: String); Procedure FixupConnections; Procedure CreateConnectionFromFixup( Const S: String); Procedure SyncModules; Protected Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp ( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseMove( Shift: TShiftState; X, Y: Integer); Override; Procedure DragStart( aPoint: TPoint); Virtual; Procedure DragEnd ( aPoint: TPoint); Virtual; Procedure DragMove ( aPoint: TPoint); Virtual; Procedure SelectModulesInRect( aRect: TRect); Procedure DefineProperties( aFiler : TFiler ); Override; Procedure WriteConnections( aWriter: TWriter); Procedure ReadConnections ( aReader: TReader); Procedure Loaded; Override; Function IndexOfModule( aModule: TCustomModule): Integer; Function ModuleCount: Integer; Procedure Notification( aComponent: TComponent; anOperation: TOperation); Override; Function WireCount: Integer; Procedure Connect( aSource, aDestination: TConnector); Public Constructor Create( anOwner: TComponent); Override; Destructor Destroy; Override; Procedure Save; Virtual; Procedure SaveAs( Const aFilename: String); Virtual; Procedure Load ( Const aFilename: String); Virtual; Procedure InvalidateWires; Procedure Disconnect( aConnector: TConnector); Function CreateModule( aModuleClass: TCustomModuleClass): TCustomModule; Procedure FreeModule( anIndex: Integer); Procedure FreeModules; Procedure FreeSelectedModules; Procedure CopyModulesToClipBoard; Procedure PasteModulesFromClipBoard; Procedure SelectAllModules; Procedure InvertModuleSelection; Public Property Module [ anIndex: Integer]: TCustomModule Read GetModule; Property Wire [ anIndex: Integer]: TWire Read GetWire; Property Source [ anIndex: Integer]: TConnector Read GetSource; Property Destination[ anIndex: Integer]: TConnector Read GetDestination; Public Property Filename : String Read FFilename Write FFilename; Published Property CurvedLines : Boolean Read GetCurvedLines Write SetCurvedLines Default True ; Property WireThickness : Integer Read GetWireThickness Write SetWireThickness Default 1 ; Property DefaultWireColor : TColor Read GetDefaultWireColor Write SetDefaultWireColor Default clBlue; Property SnapX : Integer Read FSnapX Write FSnapX Default 250; Property SnapY : Integer Read FSnapY Write FSnapY Default 15; Property SnapActive : Boolean Read FSnapActive Write FSnapActive Default True; Property Align ; Property Anchors ; Property Constraints ; Property ParentColor ; Property ParentShowHint ; Property PopupMenu ; Property ShowHint ; Property TabOrder ; Property TabStop ; Property Visible ; Property Color ; Property Top ; Property Left ; Property Width ; Property Height ; Property HorzScrollBar ; Property VertScrollBar ; End; TCustomModule = Class( TCustomPanel) // Base type for TModule, it has a title. private FAnchor : TPoint; FDistance : TPoint; FCapturing : Boolean; FSelected : Boolean; FTresholdPast : Boolean; FTmpLeft : Integer; FTmpTop : Integer; FTitleLabel : TEditLabel; FTitle : String; FPageName : String; FBitmap : TBitmap; Private Procedure MarkWires; Function UniqueName: String; Virtual; Private Procedure SetSelected ( aValue: Boolean ); Procedure SetTitle ( Const aValue: String ); Procedure SetTitleLabel( aValue: TEditLabel); Protected Procedure MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Procedure MouseMove( Shift: TShiftState; X, Y: Integer); Override; Procedure MouseUp ( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); Override; Protected Procedure Snap( Var aPoint: TPoint); Procedure Paint; Override; Procedure Loaded; Override; Procedure AssignBitmap; Virtual; Procedure ScrollSelfInView; Procedure HandleSelection( CtrlKeyActive: Boolean); Procedure UnselectPeers; Procedure BeginMove ( aPoint: TPoint); Procedure Move ( aPoint: TPoint); Procedure MoveSelected ( aPoint: TPoint); Procedure FinalMoveSelected( aPoint: TPoint; CtrlKeyActive: Boolean); Procedure InvalidateWires; procedure Notification( aComponent: TComponent; anOperation: TOperation); Override; Procedure FixOwnership( aRoot, aControl: TWinControl); Public Constructor Create( anOwner: TComponent); Override; Function Clone( anOwner: TComponent; aParent: TWinControl; anOffset: TPoint): TCustomModule; Public Procedure Restack; Procedure Disconnect; Public Property Selected : Boolean Read FSelected Write SetSelected; Property Title : String Read FTitle Write SetTitle; Property PageName : String Read FPageName Write FPageName; Published Property TitleLabel : TEditLabel Read FTitleLabel Write SetTitleLabel; End; { TFrame } TModule = class( TCustomModule) // exports stuff of TCustomModule published property BiDiMode ; property Constraints ; property Enabled ; property Color ; property Ctl3D ; property Font ; property ParentBiDiMode ; property ParentColor ; property ParentCtl3D ; property ParentFont ; property ParentShowHint ; property PopupMenu ; property ShowHint ; property TabOrder ; property TabStop ; property Visible ; property OnContextPopup ; property OnEnter ; property OnExit ; property OnMouseDown ; property OnMouseMove ; property OnMouseUp ; property OnMouseWheel ; property OnMouseWheelDown; property OnMouseWheelUp ; property OnResize ; Property Width ; Property Height ; Property Tag ; Property Title ; Property PageName ; Property BevelInner ; Property BevelOuter ; Property BevelWidth ; end; TModuleClass = Integer; // fttb ... TModuleButton = Class( TSpeedButton) Private FPageName : String; FModuleClass : TModuleClass; FModuleName : String; Public Procedure LoadGlyph; Procedure Initialize( Const aPageName: String; aModuleClass: TModuleClass; Const aModuleName: String); Public Property PageName : String Read FPageName; Property ModuleClass: TModuleClass Read FModuleClass; Property ModuleName : String Read FModuleName; End; TModuleButtonClick = Procedure( aSender: TObject; aModuleClass: TModuleClass) Of Object; TmoduleSelector = Class( TPageControl) Private FRegisteredModules : TList; FOnModuleButtonClick : TModuleButtonClick; FButtonsEnabled : Boolean; FAllowDuplicates : Boolean; Procedure SetButtonsEnabled( aValue: Boolean); Function AddPage( Const aName: String): TTabSheet; Function PageButtonCount( Const aName: String): Integer; Function PageExists( Const aName: String): Boolean; Function PageByName( Const aName: String): TTabSheet; Function FindModulePage( aModuleClass: TModuleClass): TTabSheet; Function FindModuleButton( aModuleClass: TModuleClass): TModuleButton; Procedure DoModuleMouseDown( aSender: TObject; aButton: TMouseButton; aShift: TShiftState; X, Y: Integer); Procedure FormatPage( aPage: TTabSheet); Protected Procedure Notification( aComponent: TComponent; anOperation: TOperation); Override; Public Constructor Create( anOwner: TComponent); Override; Destructor Destroy; Override; Procedure RegisterModuleClass( Const aPageName: String; aModuleClass: TModuleClass; Const aModuleName: String); Procedure UnregisterModuleClass( aModuleClass: TModuleClass); Published Property OnModuleButtonClick : TModuleButtonClick Read FonModuleButtonClick Write FOnModuleButtonClick; Property ButtonsEnabled : Boolean Read FButtonsEnabled Write SetButtonsEnabled; Property AllowDuplicates : Boolean Read FAllowDuplicates Write FAllowDuplicates Default True; End; Procedure Register; Implementation {$R Bitmaps.res} Procedure Register; // To register the components with Delphi Begin RegisterComponents( 'Knobs', [ TKnob, TSmallKnob, TDisplay, TIndicator, TInput, TOutput, TTextLabel, TEditLabel, TBox, TWirePanel, TModule, TModuleSelector ] ); End; Const InitRepeatPause = 200; // Initial pause before repeat SlowRepeatPause = 100; // RepeatPause slow repeat FastRepeatPause = 50; // RepeatPause fast repeat; SlowRepeats = 20; // After SlowRepeats repeats we start fast // repeat ClickerSize = 9; // Height for clickers Var GAnchor : TPoint = ( X: 0; Y: 0); GDistance : TPoint = ( X: 0; Y: 0); GLabelEditor : TLabelEditor = Nil; // Bitmap Id's Const idbmDn = 1; idbmUp = 2; idbmConIn = 3; idbmConOut = 4; idbmIndActive = 5; idbmIndInactive = 6; idbmKnob = 7; idbmSmallKnob = 8; idbmSkin = 9; Var bmDn : TBitmap = Nil; bmUp : TBitmap = Nil; bmConIn : TBitmap = Nil; bmConOut : TBitmap = Nil; bmIndActive : TBitmap = Nil; bmIndInactive : TBitmap = Nil; bmKnob : TBitmap = Nil; bmSmallKnob : TBitmap = Nil; bmSkin : TBitmap = Nil; Procedure LoadBitmap( Var aBitmap: TBitmap; anIndex: Integer); Begin If Not Assigned( aBitmap) Then aBitmap := TBitmap.Create; With aBitmap Do Begin LoadFromResourceID( HInstance, anIndex); TransparentMode := tmAuto; Transparent := True; End; End; Procedure CreateBitmaps; Begin LoadBitmap( bmDn , idbmDn ); LoadBitmap( bmUp , idbmUp ); LoadBitmap( bmConIn , idbmConIn ); LoadBitmap( bmConOut , idbmConOut ); LoadBitmap( bmIndActive , idbmIndActive ); LoadBitmap( bmIndInactive, idbmIndInactive); LoadBitmap( bmKnob , idbmKnob ); LoadBitmap( bmSmallKnob , idbmSmallKnob ); LoadBitmap( bmSkin , idbmSkin ); End; Procedure FreeBitmaps; Begin FreeAndNil( bmKnob ); FreeAndNil( bmSmallKnob ); FreeAndNil( bmIndActive ); FreeAndNil( bmIndInactive); FreeAndNil( bmConIn ); FreeAndNil( bmConOut ); FreeAndNil( bmDn ); FreeAndNil( bmUp ); FreeAndNil( bmSkin ); End; Procedure RegisterClasses; Begin RegisterClass( TClicker ); RegisterClass( TKnob ); RegisterClass( TSmallKnob ); RegisterClass( TDisplay ); RegisterClass( TIndicator ); RegisterClass( TConnector ); RegisterClass( TInput ); RegisterClass( TOutput ); RegisterClass( TTextLabel ); RegisterClass( TLabelEditor ); RegisterClass( TEditLabel ); RegisterClass( TWireOverlay ); RegisterClass( TWirePanel ); RegisterClass( TModule ); RegisterClass( TBox ); End; Procedure UnRegisterClasses; Begin UnRegisterClass( TClicker ); UnRegisterClass( TKnob ); UnRegisterClass( TSmallKnob ); UnRegisterClass( TDisplay ); UnRegisterClass( TIndicator ); UnRegisterClass( TConnector ); UnRegisterClass( TInput ); UnRegisterClass( TOutput ); UnRegisterClass( TTextLabel ); UnregisterClass( TLabelEditor ); UnRegisterClass( TEditLabel ); UnRegisterClass( TWireOverlay ); UnRegisterClass( TWirePanel ); UnRegisterClass( TModule ); UnregisterClass( TBox ); End; Var GBezierAngle1 : Integer = 20; GBezierStrength1: Integer = 30; GBezierAngle2 : Integer = 30; GBezierStrength2: Integer = 50; Type TBezierPoints = Array[ 0 .. 3] Of TPoint; Procedure CalcBezierCurve( Var P: TBezierPoints); Var Dir1 : TPoint; Dir2 : TPoint; Begin Dir1 := Rotate( SubPoints( P[ 0], P[ 3]), GBezierAngle1); Dir2 := Rotate( SubPoints( P[ 0], P[ 3]), GBezierAngle2); P[ 1] := SubPoints( p[ 0], DivPoint( MultPoint( Dir1, GBezierStrength1), 100)); P[ 2] := AddPoints( p[ 3], DivPoint( MultPoint( Dir2, GBezierStrength2), 100)); End; { ======== TClicker = Class( TGraphicControl) Private FRepeatTimer : TTimer; FRepeatCount : Integer; FCanRepeat : Boolean; FMouseDown : Boolean; FShowFocus : Boolean; FBitmap : TBitmap; Private Property ShowFocus: Boolean Read FShowFocus Write SetShowFocus; Public Property CanRepeat: Boolean Read FCanRepeat Write FCanRepeat Default True; Private } Procedure TClicker.TimerExpired( aSender: TObject); Begin With FRepeatTimer Do If FRepeatCount > SlowRepeats Then Interval := FastRepeatPause Else Interval := SlowRepeatPause; If FMouseDown And MouseCapture Then Try Click; Except FRepeatTimer.Enabled := False; Raise; End; Inc( FRepeatCount); End; Procedure TClicker.SetShowFocus( aValue: Boolean); Begin If aValue <> FShowFocus Then Begin FShowFocus := aValue; Flat := Not FShowFocus; If ShowFocus Then Glyph := FBitmap Else Glyph := Nil; Invalidate; End; End; // Protected Procedure TClicker.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If CanRepeat Then Begin FMouseDown := True; FRepeatCount := 0; If Not Assigned( FRepeatTimer) Then FRepeatTimer := TTimer.Create( Self); With FRepeatTimer Do Begin OnTimer := TimerExpired; Interval := InitRepeatPause; Enabled := True; End; End; End; Procedure TClicker.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If Assigned( FRepeatTimer) Then FRepeatTimer.Enabled := False; End; Procedure TClicker.AssignBitmap( aBitmap: TBitmap); Begin FBitmap := aBitmap; End; // Public Constructor TClicker.Create( anOwner: TComponent); // Override; Begin Inherited; CanRepeat := True; Transparent := True; Flat := True; End; Destructor TClicker.Destroy; // Override; Begin If Assigned( FRepeatTimer) Then FRepeatTimer.Free; Inherited; End; Procedure TClicker.Click; // Override; Begin Inherited; If HasParent Then Parent.SetFocus; End; { ======== TKnob = class( TCustomControl) Private FMinValue : TValue; FMaxValue : TValue; FValue : TValue; FStepSize : TValue; FOnValueChange : TOnValueChange; FDownClicker : TClicker; FUpClicker : TClicker; FMouseDown : Boolean; FBitmap : TBitmap; FDisplayFormat : String; FMouseInControl: Boolean; FTransparent : Boolean; FDisplay : TDisplay; Public Property AsString: String Read GetAsString; Published Property MinValue : TValue Read FMinValue Write SetMinValue; Property MaxValue : TValue Read FMaxValue Write SetMaxValue; Property Value : TValue Read FValue Write SetValue; Property StepSize : TValue Read FStepSize Write SetStepSize; Property DisplayFormat: String Read FDisplayFormat Write SetDisplayFormat; Property Transparent : Boolean Read FTransparent Write SetTransparent; Property Color; Property Display : TDisplay Read FDisplay Write SetDisplay; Property OnValueChange: TOnValueChange Read FOnValueChange Write SetOnValueChange; Private } procedure TKnob.WMSetFocus( Var Message: TWMSetFocus ); // Message WM_SETFOCUS; Begin FUpClicker .ShowFocus := True; FDownClicker.ShowFocus := True; Invalidate; Inherited; End; procedure TKnob.WMKillFocus( Var Message: TWMKillFocus); // Message WM_KILLFOCUS; Begin FUpClicker .ShowFocus := False; FDownClicker.ShowFocus := False; Invalidate; Inherited; End; procedure TKnob.WMGetDlgCode( Var Message: TWMGetDlgCode); // Message WM_GETDLGCODE; Begin Message.Result := DLGC_WANTARROWS; End; procedure TKnob.CMMouseEnter(var Message: TMessage); begin inherited; If Not FMouseInControl And Enabled And ( GetCapture = 0) Then Begin FMouseInControl := True; Invalidate; end; end; procedure TKnob.CMMouseLeave(var Message: TMessage); begin inherited; If FMouseInControl And Enabled And Not Dragging Then Begin FMouseInControl := False; Invalidate; end; end; Function TKnob.CreateClicker( aLeft, aTop: Integer; aNotifyEvent: TNotifyEvent; aBitmap: TBitmap): TClicker; Begin Result := TClicker.Create( Self); With Result Do Begin Left := aLeft; Top := aTop; Width := Self.Width Div 2; Height := ClickerSize; OnClick := aNotifyEvent; Parent := Self; AssignBitmap( aBitmap); End; End; Procedure TKnob.OnDownClick( aSender: TObject); Begin Value := Value - StepSize; End; Procedure TKnob.OnUpClick( aSender: TObject); Begin Value := Value + StepSize; End; Function TKnob.GetAsString: String; Begin If FUseNoteName Then Result := IntegerToNoteStr( Round( Value)) Else Result := Format( DisplayFormat, [ Value]); End; Procedure TKnob.NotifyEnvironment; Begin If Assigned( FDisplay) Then FDisplay.Caption := AsString; If Assigned( FOnValueChange) Then FOnValueChange( Self, FValue, AsString); End; Procedure TKnob.SetMinValue( aValue: TValue); Begin If aValue <> FMinValue Then Begin FMinValue := aValue; Value := Value; Invalidate; End; End; Procedure TKnob.SetMaxValue( aValue: TValue); Begin If aValue <> FMaxValue Then Begin FMaxValue := aValue; Value := Value; Invalidate; End; End; Procedure TKnob.SetValue( aValue: TValue); Begin Clip( aValue, MinValue, MaxValue); RoundToStepValue( aValue, StepSize); If aValue <> FValue Then Begin FValue := aValue; Hint := AsString; Invalidate; NotifyEnvironment; End; End; Procedure TKnob.SetStepSize( aValue: TValue); Begin If aValue <> FStepSize Then Begin FStepSize := aValue; Invalidate; End; End; Procedure TKnob.SetDisplayFormat( Const aValue: String); Begin If aValue <> FDisplayFormat Then Begin FDisplayFormat := aValue; NotifyEnvironment; End; End; Procedure TKnob.SetUseNoteName( aValue: Boolean); Begin If aValue <> FUseNoteName Then Begin FUseNoteName := aValue; NotifyEnvironment; End; End; Procedure TKnob.SetTransparent( aValue: Boolean); Begin If aValue <> FTransparent Then Begin FTransparent := aValue; Invalidate; End; End; Procedure TKnob.SetDisplay( aValue: TDisplay); Begin FDisplay := aValue; If Assigned( FDisplay) Then FDisplay.Caption := AsString; End; Procedure TKnob.SetOnValueChange( aValue: TOnValueChange); Begin FOnValueChange := aValue; If Assigned( FOnValueChange) Then FOnValueChange( Self, Value, AsString); End; Function TKnob.CenterPoint: TPoint; Begin With Result Do Begin x := Width Div 2; y := ( Height - 5) Div 2; End; End; Function TKnob.CreateRgn: HRGN; Var HR : HRGN; OP : HPEN; DC : HDC; Begin If FTransparent Then Begin Result := CreateEllipticRgn( 1, 1, Width - 1, Height - 6); If Focused { Or FDownClicker.MouseInControl Or FUpClicker.MouseInControl Or FMouseInControl Or ( csDesigning In ComponentState) } Then Begin HR := CreateRectRgn( 0, Height - ClickerSize, Width - 1, Height); CombineRgn( Result, Result, HR, RGN_OR); DeleteObject( HR); End Else Begin With Canvas Do Begin Pen.Width := 2; DC := CreateCompatibleDC( Handle); End; OP := SelectObject( DC, Canvas.Pen.Handle); Try BeginPath( DC); With CenterPoint Do MoveToEx( DC, X, Y, Nil); LineTo( DC, 2, Height - 8); EndPath( DC); WidenPath( DC); HR := PathToRegion( DC); CombineRgn( Result, Result, HR, RGN_OR); DeleteObject( HR); BeginPath( DC); With CenterPoint Do MoveToEx( DC, X, Y, Nil); LineTo( DC, Width - 2, Height - 8); EndPath( DC); WidenPath( DC); HR := PathToRegion( DC); CombineRgn( Result, Result, HR, RGN_OR); DeleteObject( HR); Finally SelectObject( DC, OP); DeleteDC( DC); End; End; End Else Result := CreateRectRgn( 0, 0, Width, Height); End; Procedure TKnob.BeginMove( aPoint: TPoint); // Override; Var P : TPoint; Begin P := PolarToPoint( CenterPoint, ValuesToAngle( MinValue, Value, MaxValue), Width / 2); With ClientToScreen( P) Do SetCursorPos( X, Y); GDistance := SubPoints( CenterPoint, P); GAnchor := CenterPoint; End; Procedure TKnob.EndMove( aPoint: TPoint); // Override; Begin Value := DistanceToValue( MinValue, MaxValue, aPoint); End; Procedure TKnob.UpdateMove( aPoint: TPoint); // Override; Begin Value := DistanceToValue( MinValue, MaxValue, aPoint); End; // Protected Procedure TKnob.Paint; // Override; Var S : TPoint; E : TPoint; A : TAngle; Begin If Not ( csDesigning In ComponentState) Then SetWindowRgn( Handle, CreateRgn, True); With Canvas Do Begin FBitmap.Transparent := Not FTransparent; Draw( 1, 1, FBitmap); If Focused Then Pen.Color := clRed Else Pen.Color := clBlack; Pen.Width := 1; A := ValuesToAngle( MinValue, Value, MaxValue); S := PolarToPoint( CenterPoint, A, 1); E := PolarToPoint( CenterPoint, A, Width Div 2 - 1); MoveTo( S.x, S.y); LineTo( E.x, E.y); End; End; Procedure TKnob.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If Button = mbLeft Then Begin If TabStop And ( GetFocus <> Handle) And CanFocus Then SetFocus; GAnchor := Point( X, Y); GDistance := Point( X, Y); BeginMove ( GAnchor ); UpdateMove( GDistance); FMouseDown := True; end; End; Procedure TKnob.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If FMouseDown Then Begin UpdateMove( GDistance); GDistance.x := X - GAnchor.x; GDistance.y := Y - GAnchor.y; FMouseDown := False; EndMove( GDistance); End; End; Procedure TKnob.MouseMove( Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If FMouseDown Then Begin UpdateMove( GDistance); GDistance.x := X - GAnchor.x; GDistance.y := Y - GAnchor.y; UpdateMove( GDistance); End; End; procedure TKnob.KeyDown( Var Key: Word; Shift: TShiftState); // Override; Begin case Key of VK_UP : FUpClicker .Click; VK_DOWN : FDownClicker.Click; end; End; Procedure TKnob.AssignBitmap; // Virtual; Begin FBitmap := bmKnob; End; Procedure TKnob.Loaded; // Override; Begin Inherited; NotifyEnvironment; Hint := AsString; End; // Public Constructor TKnob.Create( anOwner: TComponent); // Override; Begin Inherited; ControlStyle := ControlStyle - [ csSetCaption, csOpaque]; AssignBitmap; Width := FBitmap.Width + 2; Height := FBitmap.Height + 7; MinValue := 0.00; MaxValue := 1.00; Value := 0.50; StepSize := 0.01; FDownClicker := CreateClicker( 0 , Height - ClickerSize, OnDownClick, bmDn); FUpClicker := CreateClicker( Width Div 2, Height - ClickerSize, OnUpClick , bmUp); DoubleBuffered := True; TabStop := True; ShowHint := True; DisplayFormat := '%.2f'; Color := clWhite; End; { ======== TSmallKnob = Class( TKnob) Public } Procedure TSmallKnob.AssignBitmap; // Overide; Begin FBitmap := bmSmallKnob; End; { ======== TDisplay = Class( TStaticText) Published Property Color Default ColorDisplay; Property Width Default 33; Property Height Default 15; Property AutoSize Default False; Property BorderStyle Default sbsSunken; Protected } Procedure TDisplay.WMNCHitTest( Var aMessage: TWMNCHitTest); // Message WM_NCHITTEST; Begin If csDesigning In ComponentState Then Inherited Else aMessage.Result := HTTRANSPARENT; End; Procedure TDisplay.Loaded; // Override; Begin Inherited; Height := 15; End; // Public Constructor TDisplay.Create( anOwner: TComponent); // Override; Begin Inherited; ControlStyle := ControlStyle - [ csSetCaption]; Color := ColorDisplay; AutoSize := False; BorderStyle := sbsSunken; Font.Color := clWhite; Caption := '0.57'; Width := 33; Height := 15; DoubleBuffered := True; End; { ======== TIndicator = Class( TGraphicControl) Private FActive : Boolean; FActiveBm : TBitmap; FInActiveBm : TBitmap; Property BitnapActive : TBitmap Read FActiveBm Write SetBitmapActive; Property BitnapInactive : TBitmap Read FInactiveBm Write SetBitmapInactive; Published Property Active : Boolean Read FActive Write SetActive; Private } Procedure TIndicator.SetActive( aValue: Boolean); Begin If aValue <> FActive Then Begin FActive := aValue; Invalidate; End; End; Procedure TIndicator.SetBitmapActive( aValue: TBitmap); Begin FActiveBm.Assign( aValue); If FActive Then Invalidate; End; Procedure TIndicator.SetBitmapInactive( aValue: TBitmap); Begin FInactiveBm.Assign( aValue); If Not FActive Then Invalidate; End; // Protected Procedure TIndicator.AssignBitmaps; Begin FInactiveBm := bmIndInactive; FActiveBm := bmIndActive ; End; Procedure TIndicator.Paint; // Override; Begin Inherited; With Canvas Do If Active Then Draw( 0, 0, FActiveBm ) Else Draw( 0, 0, FInactiveBm); End; // Public Constructor TIndicator.Create( anOwner: TComponent); // Override; Begin Inherited; AssignBitmaps; Width := Max( FActiveBm.Width , FInactiveBm.Width ); Height := Max( FActiveBm.Height, FInactiveBm.Height); Enabled := False; End; { ======== TConnector = Class( TGraphicControl) Private FBitmap : TBitmap; FDoubleClicked : Boolean; FMouseDown : Boolean; FConnected : Boolean; // True when at least on connection exists FHighLight : Boolean; // Highlighted connections FLinks : TList; // Connections from this connector FBlockRecur : Boolean; // Flag to block unwanted recursion FWireColor : TColor; Public Property Connected : Boolean Read FConnected Write SetConnected; Published Property WireColor : TColor Read FWireColor Write SetWireColor Default clBlue; Private } Procedure TConnector.SetConnected( aValue: Boolean); Begin If aValue <> FConnected Then Begin FConnected := aValue; Invalidate; End; End; Procedure TConnector.SetHighLight( aValue: Boolean); Var i : Integer; Const Depth : Integer = 0; Begin If aValue <> FHighLight Then Begin If Not FBlockRecur Then Try FBlockRecur := True; FHighLight := aValue; Invalidate; Inc( Depth); Try With FLinks Do For i := 0 To Count - 1 Do TConnector( Items[ i]).HighLight := aValue; Finally Dec( Depth); End; Finally FBlockRecur := False; End; End; If Depth = 0 Then SendHighlightNotification; End; Procedure TConnector.SetWireColor( aValue: TColor); Begin If aValue <> FWireColor Then Begin FWireColor := aValue; SendColorNotification( FWireColor); Invalidate; End; End; Procedure TConnector.AddLink( aConnector: TConnector); Begin If Not HasLinkTo( aConnector) Then Begin FLinks.Add( aConnector); aConnector.AddBackLink( Self); Connected := True; SendWireNotification( UM_CONNECTIONADD, aConnector); End; End; Procedure TConnector.DelLink( aConnector: TConnector); Begin If HasLinkTo( aConnector) Then Begin FLinks.Remove( aConnector); aConnector.DelBackLink( Self); Connected := FLinks.Count > 0; SendWireNotification( UM_CONNECTIONREMOVE, aConnector); End; End; Procedure TConnector.AddBackLink( aConnector: TConnector); Begin If Not HasLinkTo( aConnector) Then Begin FLinks.Add( aConnector); Connected := True; End; End; Procedure TConnector.MoveLinksTo( aConnector: TConnector); Var aMoved : TConnector; Begin If Assigned( aConnector) Then Begin With FLinks Do If aConnector <> Self Then Begin While Count > 0 Do Begin aMoved := TConnector( Items[ Count - 1]); DelLink( aMoved); aConnector.AddLink( aMoved); End; End; End Else DelLinks; End; Procedure TConnector.DelLinks; Begin With FLinks Do While Count > 0 Do DelLink( Items[ Count - 1]) End; Procedure TConnector.DelBackLink( aConnector: TConnector); Begin Connected := False; With FLinks Do Begin Remove( aConnector); Connected := Count > 0; End; End; Function TConnector.HaslinkTo( aConnector: TConnector): Boolean; Begin Result := FLinks.IndexOf( aConnector) >= 0; End; Function TConnector.FindConnector( aScreenPoint: TPoint): TConnector; Var aControl : TControl; Begin Result := Nil; aControl := FindDragTarget( aScreenPoint, True); If Assigned( aControl) And ( aControl Is TConnector) Then Result := TConnector( aControl); End; Procedure TConnector.DrawLine( X, Y: Integer); Var aDC : HDC; aPen : HPen; OldObj : HGDIOBJ; aColor : TColor; Begin aColor := clWhite; aDC := GetDC( 0); Try SetRop2( aDC, R2_XORPEN); aPen := CreatePen( PS_SOLID, 1, ColorToRGB( aColor)); OldObj := SelectObject( aDC, aPen); Try With ClientToScreen( CenterPoint) Do MoveToEx( aDC, X, Y, Nil); With ClientToScreen( Point( X, Y)) Do LineTo( aDC, X, Y); Finally SelectObject( aDC, OldObj); DeleteObject( aPen); End; Finally ReleaseDC( 0, aDC); End; End; Procedure TConnector.SendWireNotification( Msg: Cardinal; aConnector: TConnector); Var aParent : TWinControl; Begin aParent := Parent; While Assigned( aParent) And Not ( aParent Is TWirePanel) Do aParent := aParent.Parent; If aParent Is TWirePanel Then TWirePanel( aParent).Perform( Msg, LongInt( Self), LongInt( aConnector)); End; Procedure TConnector.SendColorNotification( aColor: TColor); Var aParent : TWinControl; Begin aParent := Parent; While Assigned( aParent) And Not ( aParent Is TWirePanel) Do aParent := aParent.Parent; If aParent Is TWirePanel Then TWirePanel( aParent).Perform( UM_COLORCHANGE, LongInt( Self), aColor); End; Procedure TConnector.SendHighlightNotification; Var aParent : TWinControl; Begin aParent := Parent; While Assigned( aParent) And Not ( aParent Is TWirePanel) Do aParent := aParent.Parent; If aParent Is TWirePanel Then TWirePanel( aParent).Perform( UM_HIGHLIGHT, 0, 0); End; // Protected Function TConnector.CenterPoint: TPoint; Begin With Result Do Begin x := Width Div 2; y := Height Div 2; End; End; Procedure TConnector.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If Button = mbLeft Then Begin FMouseDown := True; FDoubleClicked := ssDouble In Shift; GDistance := Point( X, Y); DrawLine( X, Y); HighLight := True; End; End; Procedure TConnector.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Var aConnector : TConnector; Begin Inherited; If FMouseDown Then Begin HighLight := False; With GDistance Do DrawLine( X, Y); FMouseDown := False; Screen.Cursor := crDefault; aConnector := FindConnector( ClientToScreen( Point( X, Y))); If Assigned( aConnector) And Not aConnector.CanAccept( Self) Then aConnector := Nil; If FDoubleClicked Then MoveLinksTo( aConnector) Else ConnectTo ( aConnector); End; End; Procedure TConnector.MouseMove( Shift: TShiftState; X, Y: Integer); // Override; Var aConnector : TConnector; Begin Inherited; If FMouseDown Then Begin With GDistance Do DrawLine( X, Y); GDistance := Point( X, Y); With GDistance Do DrawLine( X, Y); aConnector := FindConnector( ClientToScreen( Point( X, Y))); With Screen Do If Assigned( aConnector) And aConnector.CanAccept( Self) Then Begin If FDoubleClicked Then Cursor := crMultiDrag Else Cursor := crHandPoint; End Else If Assigned( aConnector) And ( aConnector <> Self) Then Cursor := crNoDrop Else Cursor := crDefault; End; End; Function TConnector.FindOutput: TConnector; Var i : Integer; Begin If Self Is TOutput Then Result := Self Else Begin Result := Nil; If Not FBlockRecur Then Begin FBlockRecur := True; Try With FLinks Do For i := 0 To Count - 1 Do Begin Result := TConnector( Items[ i]).FindOutput; If Assigned( Result) Then Break; End; Finally FBlockRecur := False; End; End; End; End; Function TConnector.IsConnectedToOutput: Boolean; Begin Result := FindOutput <> Nil; End; Function TConnector.OutputColor: TColor; Var aConnector : TConnector; Begin aConnector := FindOutput; If Assigned( aConnector) Then Result := aConnector.WireColor Else Result := clBlue; End; Function TConnector.CanAccept( aSource: TConnector): Boolean; Begin Result := Assigned( aSource) And ( ( ( aSource <> Self) And Not ( IsConnectedToOutput And aSource.IsConnectedToOutput ) ) Or ( aSource.FDoubleClicked And ( aSource Is TOutput) ) ); End; Procedure TConnector.ConnectTo( aConnector: TConnector); Begin If Assigned( aConnector) And aConnector.CanAccept( Self) Then AddLink( aConnector); End; Procedure TConnector.DisConnect; Begin DelLinks; End; Procedure TConnector.Paint; // Override; Begin With Canvas Do Begin Draw( 0, 0, FBitmap); If FHighLight Or FConnected Then Begin If FHighLight Then Brush.Color := clWhite Else If FConnected Then Brush.Color := OutputColor; Ellipse( 2, 2, Width - 2, Height - 2); End; End; End; // Public Constructor TConnector.Create( anOwner: TComponent); // Override; Begin Inherited; AssignBitmap; Width := FBitmap.Width; Height := FBitmap.Height; FLinks := TList.Create; FWireColor := clBlue; End; Destructor TConnector.Destroy; // Override; Begin DelLinks; FLinks.Free; Inherited; End; { ======== TInput = Class( TConnector) Protected } Procedure TInput.AssignBitmap; // Override; Begin FBitmap := bmConIn; End; { ======== TOutput = Class( TConnector) Protected } Procedure TOutput.AssignBitmap; // Override; Begin FBitmap := bmConOut; End; { ======== TTextLabel = Class( TLabel) Protected } Procedure TTextLabel.DoDrawText( Var aRect: TRect; aFlags: Longint); // Override; Var Text: String; begin Text := GetLabelText; aFlags := aFlags or DT_NOPREFIX; aFlags := DrawTextBiDiModeFlags( aFlags); Canvas.Font := Font; DrawText( Canvas.Handle, PChar( Text), Length( Text), aRect, aFlags); End; // Public Constructor TTextLabel.Create( anOwner: TComponent); // Override; Begin Inherited; With Font Do Begin Name := 'Small Fonts'; Size := 7; End; Enabled := False; Transparent := True; End; { ======== TLabelEditor = Class( TEdit) Private } procedure TLabelEditor.WMKillFocus( Var Message: TWMKillFocus ); // Message WM_KILLFOCUS; Begin Inherited; Visible := False; End; Procedure TLabelEditor.Do_Exit( aSender: TObject); Begin FLabel.Caption := Text; Visible := False; End; Procedure TLabelEditor.Do_KeyDown( aSender: TObject; Var aKey: Word; aShift: TShiftState); Begin If aShift = [] Then Case aKey Of VK_RETURN, VK_ESCAPE : Begin FLabel.Caption := Text; Visible := False; aKey := 0; End; End; End; // Protected Procedure TLabelEditor.SetLabel( aLabel: TEditLabel); Begin FLabel := aLabel; Parent := aLabel.Parent; Text := aLabel.Caption; Visible := True; SetFocus; End; // Public Constructor TLabelEditor.Create( anOwner: TComponent); // Override; Begin Inherited; Visible := False; Left := 1; Top := 1; OnExit := Do_Exit; OnKeyDown := Do_KeyDown; End; { ======== TEditLabel = Class( TTextLabel) // a label with a popup editor Private FLabelEditor : TLabelEditor; Protected } Procedure TEditLabel.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin If ( ssDouble In Shift) And ( Button = mbLeft) Then Begin If GLabelEditor = Nil Then GLabelEditor := TLabelEditor.Create( Application); GLabelEditor.SetLabel( Self); End; End; // Public Constructor TEditLabel.Create( anOwner: TComponent); // Override; Begin Inherited; AutoSize := False; Width := 75; Enabled := True; End; { ======== TBox = Class( TBevel) Published Property Enabled Default False; Public } Constructor TBox.Create( anOwner: TComponent); // Override; Begin Inherited; Enabled := False; End; { ======== TDrawPanel = Class( TCustomControl) Protected } { TWire = Class Public FSource : TConnector; FDestination : TConnector; FHighlight : Boolean; } Constructor TWire.Create( aSource, aDestination: TConnector); Begin Inherited Create; FSource := aSource; FDestination := aDestination; End; { ======== TWireOverlay = Class( TCustomControl) Private FWires : TObjectList; FCurvedLines : Boolean; FWireThickness : Integer; FDefaultWireColor : TColor; Public Property Wire [ anIndex: Integer]: TWire Read GetWire; Property Source [ anIndex: Integer]: TConnector Read GetSource; Property Destination[ anIndex: Integer]: TConnector Read GetDestination; Published Property CurvedLines : Boolean Read FCurvedLines Write SetCurvedLines Default True; Property WireThickness : Integer Read FWireThickness Write SetWireThickness NoDefault; Property DefaultWireColor : TColor Read FDefaultWireColor Write FDefaultWireColor Default clBlue; Private } Procedure TWireOverlay.WMNCHitTest( Var aMessage: TWMNCHitTest); // message WM_NCHITTEST; Begin If csDesigning In ComponentState Then Inherited Else aMessage.Result := HTTRANSPARENT; End; Procedure TWireOverlay.MarkWires( aConnector: TConnector); Var i : Integer; Begin For i := 0 To WireCount - 1 Do With Wire[ i] Do If ( FSource = aConnector) Or ( FDestination = aConnector) Then FMarked := True; End; Function TWireOverlay.GetWire( anIndex: Integer): TWire; Begin Result := TWire( FWires[ anIndex]); End; Function TWireOverlay.GetSource( anIndex: Integer): TConnector; Begin Result := Wire[ anIndex].FSource; End; Function TWireOverlay.GetDestination( anIndex: Integer): TConnector; Begin Result := Wire[ anIndex].FDestination; End; Procedure TWireOverlay.SetCurvedLines( aValue: Boolean); Begin If aValue <> FCurvedLines Then Begin FCurvedLines := aValue; InvalidateWires; End; End; Procedure TWireOverlay.SetWireThickNess( aValue: Integer); Begin If aValue <> FWireThickness Then Begin FWireThickness := aValue; InvalidateWires; End; End; // Protected Procedure TWireOverlay.Paint; // Override; Var i : Integer; O : TConnector; Begin With Canvas Do Begin Pen.Width := FWireThickness + 1; For i := 0 To WireCount - 1 Do Begin With Wire[ i] Do Begin O := FSource.FindOutput; If FHighlight Or ( O = Nil) Then Pen.Color := clWhite Else Pen.Color := O.WireColor; End; PaintWire( Handle, Wire[ i]); End; End; End; Procedure TWireOverlay.PaintWire( aDC: HDC; aWire: TWire); Var Points : TBezierPoints; Begin With aWire Do Begin With FSource Do Points[ 0] := ClientToScreen( CenterPoint); Points[ 0] := ScreenToClient( Points[ 0]); With FDestination Do Points[ 3] := ClientToScreen( CenterPoint); Points[ 3] := ScreenToClient( Points[ 3]); If CurvedLines Then Begin CalcBezierCurve( Points); PolyBezier( aDC, Points, 4); End Else Begin With Points[ 0] Do MoveToEx( aDC, X, Y, Nil); With Points[ 3] Do LineTo ( aDC, X, Y ); End; End; End; Function TWireOverlay.FindWire( aSource, aDestination: TConnector): Integer; Var i : Integer; Begin Result := -1; For i := 0 To WireCount - 1 Do If (( Wire[ i].FSource = aSource) And ( Wire[ i].FDestination = aDestination)) or (( Wire[ i].FSource = aDestination) And ( Wire[ i].FDestination = aSource)) Then Begin Result := i; Break; End; End; Procedure TWireOverlay.AddWire( aSource, aDestination: TConnector); Var anIndex: Integer; Begin anIndex := FindWire( aSource, aDestination); If anIndex < 0 Then Begin If ( aSource Is TInput) And ( aDestination Is TOutput) Then FWires.Add( TWire.Create( aDestination, aSource)) Else FWires.Add( TWire.Create( aSource, aDestination)); InvalidateWires; End; End; Procedure TWireOverlay.DelWire( aSource, aDestination: TConnector); Var anIndex : Integer; Begin anIndex := FindWire( aSource, aDestination); If anIndex >= 0 Then Begin FWires.Delete( anIndex); InvalidateWires; End; End; Procedure TWireOverlay.Connect( aSource, aDestination: TConnector); Begin If Assigned( aSource) Then aSource.ConnectTo( aDestination); End; Procedure TWireOverlay.HandleHighlight; Var i : Integer; Begin For i := 0 To WireCount - 1 Do With Wire[ i] Do FHighlight := FSource.HighLight Or FDestination.HighLight; Invalidate; End; Procedure TWireOverlay.HandleColorChange( aSource: TConnector; aColor: TColor); Begin InvalidateWires; End; Function TWireOverlay.WireCount: Integer; Begin If Assigned( FWires) Then Result := FWires.Count Else Result := 0; End; // Public Constructor TWireOverlay.Create( anOwner: TComponent); // Override; Begin Inherited; FWires := TObjectList.Create; Align := alClient; FCurvedLines := True; FWireThickness := 1; FDefaultWireColor := clBlue; DoubleBuffered := True; End; Destructor TWireOverlay.Destroy; // Override; Begin FreeAndNil( FWires); Inherited; End; Procedure TWireOverlay.InvalidateWires; Function CreateRgn( aDC: HDC; aWire: TWire): HRGN; Begin BeginPath ( aDC); PaintWire ( aDC, aWire); EndPath ( aDC); WidenPath ( aDC); Result := PathToRegion( aDC); End; Var DC : HDC; i : Integer; HR : HRGN; GR : HRGN; OP : HPEN; Begin If Not ( HasParent And Parent.HasParent) Then Exit; BringToFront; // See @@@@1 remarks. With Canvas Do Begin Pen.Width := FWireThickness; DC := CreateCompatibleDC( Handle); OP := SelectObject( DC, Pen.Handle); End; Try If WireCount > 0 Then Begin HR := CreateRgn( DC, Wire[ 0]); For i := 1 To WireCount - 1 Do Begin GR := CreateRgn( DC, Wire[ i]); CombineRgn( GR, GR, HR, RGN_OR); DeleteObject( HR); HR := GR; End; End Else HR := CreateRectRgn( 0, 0, 1, 1); SetWindowRgn( Handle, HR, True); BringToFront; Finally SelectObject( DC, OP); DeleteDC( DC); End; Invalidate; // Repaint is not automatic ... End; Procedure TWireOverlay.Disconnect( aConnector: TConnector); Var i : Integer; Begin For i := WireCount - 1 Downto 0 Do With Wire[ i] Do If ( FSource = aConnector) Or ( FDestination = aConnector) Then FWires.Delete( i); End; { ======== TUMConnectionChange = Packed Record Msg : Cardinal; Source : TConnector; Destination : TConnector; Result : LongInt; End; TUMColorChange = Packed Record Msg : Cardinal; Source : TConnector; Color : TColor; Result : LongInt; End; TUMConnectionAdd = TUMConnectionChange; TUMConnectionRemove = TUMConnectionChange; TUMHighlight = Packed Record Msg : Cardinal; NotUsed1 : LongInt; NotUsed2 : LongInt; Result : LongInt; End; } { ======== TWirePanel = Class( TScrollingWinControl) Private FMouseDown : Boolean; FWireOverlay : TWireOverlay; FModules : TList; FConnectionFixups : TStringList; FFilename : String; FSnapX : Integer; FSnapY : Integer; FSnapActive : Boolean; Public Property Module [ anIndex: Integer]: TCustomModule Read GetModule; Property Wire [ anIndex: Integer]: TWire Read GetWire; Property Source [ anIndex: Integer]: TConnector Read GetSource; Property Destination[ anIndex: Integer]: TConnector Read GetDestination; Public Property Filename : String Read FFilename Write FFilename ; Published Property CurvedLines : Boolean Read GetCurvedLines Write SetCurvedLines Default True ; Property WireThickness : Integer Read GetWireThickness Write SetWireThickness Default 1 ; Property DefaultWireColor : TColor Read GetDefaultWireColor Write SetDefaultWireColor Default clBlue; Property SnapX : Integer Read FSnapX Write FSnapX ; Property SnapY : Integer Read FSnapY Write FSnapY ; Property SnapActive : Boolean Read FSnapActive Write FSnapActive; Property Align ; Property Anchors ; Property Constraints ; Property ParentColor ; Property ParentShowHint ; Property PopupMenu ; Property ShowHint ; Property TabOrder ; Property TabStop ; Property Visible ; Property Color ; Property Top ; Property Left ; Property Width ; Property Height ; Property HorzScrollBar ; Property VertScrollBar ; Private } Procedure TWirePanel.MarkWires( aConnector: TConnector); Begin If Assigned( FWireOverlay) Then FWireOverlay.MarkWires( aConnector); End; // Protected Procedure TWirePanel.UMConnectionAdd( Var aMessage: TUMConnectionAdd ); // Message UM_CONNECTIONADD; Begin With aMessage Do FWireOverlay.AddWire( Source, Destination); End; Procedure TWirePanel.UMConnectionRemove( Var aMessage: TUMConnectionRemove); // Message UM_CONNECTIONREMOVE; Begin With aMessage Do FWireOverlay.DelWire( Source, Destination); End; Procedure TWirePanel.UMColorChange( Var aMessage: TUMColorChange); // Message UM_COLORCHANGE; Begin With aMessage Do FWireOverlay.HandleColorChange( Source, Color); End; Procedure TWirePanel.UMHighlight( Var aMessage: TUMHighlight); // Message UM_HIGHLIGHT; Begin FWireOverlay.HandleHighlight; End; Function TWirePanel.GetModule( anIndex: Integer): TCustomModule; Begin If ( anIndex >= 0) And ( anIndex < ModuleCount) Then Result := TCustomModule( FModules[ anIndex]) Else Result := Nil; End; Function TWirePanel.GetWire( anIndex: Integer): TWire; Begin If Assigned( FWireOverlay) Then Result := FWireOverlay.Wire[ anIndex] Else Result := Nil; End; Function TWirePanel.GetSource( anIndex: Integer): TConnector; Begin If Assigned( FWireOverlay) Then Result := FWireOverlay.Source[ anIndex] Else Result := Nil; End; Function TWirePanel.GetDestination( anIndex: Integer): TConnector; Begin If Assigned( FWireOverlay) Then Result := FWireOverlay.Destination[ anIndex] Else Result := Nil; End; Function TWirePanel.GetCurvedLines: Boolean; Begin Result := FWireOverlay.CurvedLines; End; Procedure TWirePanel.SetCurvedLines( aValue: Boolean); Begin FWireOverlay.CurvedLines := aValue; End; Function TWirePanel.GetWireThickness: Integer; Begin Result := FWireOverlay.WireThickness; End; Procedure TWirePanel.SetWireThickness( aValue: Integer); Begin FWireOverlay.WireThickness := aValue; End; Function TWirePanel.GetDefaultWireColor: TColor; Begin Result := FWireOverlay.DefaultWireColor; End; Procedure TWirePanel.SetDefaultWireColor( aValue: TColor); Begin FWireOverlay.DefaultWireColor := aValue; End; Procedure TWirePanel.ClearConnectionFixups; Begin If Assigned( FConnectionFixUps) Then FConnectionFixups.Clear Else FConnectionFixups := TStringList.Create; End; Procedure TWirePanel.AddConnectionFixup( Const S: String); Begin FConnectionFixups.Add( S); End; Procedure TWirePanel.FixupConnections; Var i : Integer; HadException : Boolean; Begin Try HadException := False; With FConnectionFixups Do For i := 0 To Count - 1 Do Try CreateConnectionFromFixup( Strings[ i]); Except On E:ECorruptPatch Do If Not HadException Then Begin HadException := True; ShowMessage( E.Message); End; End; Finally FConnectionFixups.Free; FConnectionFixups := Nil; End; End; Procedure TWirePanel.CreateConnectionFromFixup( Const S: String); Const Nums : Set Of Char = [ '0' .. '9']; Ascs : Set Of Char = [ '0' .. '9', 'A' .. 'Z', 'a' .. 'z']; Var p : Integer; i : Integer; SrcModNm : String; SrcConNm : String; DstModNm : String; DstConNm : String; SrcMod : TCustomModule; SrcCon : TConnector; DstMod : TCustomModule; DstCon : TConnector; Begin p := 1; i := 1; If Length( S) > 0 Then Begin While ( p <= Length( S)) And ( S[ p] In Ascs) Do Inc( p); SrcModNm := Copy( S, i, p - i); If ( p > Length( S)) Or ( S[ p] <> '.') Then Exit Else Inc( p); i := p; While ( p <= Length( S)) And ( S[ p] In Ascs) Do Inc( p); SrcConNm := Copy( S, i, p - i); If ( p > Length( S)) Or ( S[ p] <> ' ') Then Exit Else Inc( p); i := p; While ( p <= Length( S)) And ( S[ p] In Ascs) Do Inc( p); DstModNm := Copy( S, i, p - i); If ( p > Length( S)) Or ( S[ p] <> '.') Then Exit Else Inc( p); i := p; While ( p <= Length( S)) And ( S[ p] In Ascs) Do Inc( p); DstConNm := Copy( S, i, p - i); Try SrcMod := FindComponent( SrcModNm) As TCustomModule; SrcCon := SrcMod.FindComponent( SrcConNm) As TConnector; DstMod := FindComponent( DstModNm) As TCustomModule; DstCon := DstMod.FindComponent( DstConNm) As TConnector; Connect( SrcCon, DstCon); Except On Exception Do Raise ECorruptPatch. Create( 'The patch is corrupted or incompatible:'^M + 'can''t make all the connections.' ); End; End Else Raise ECorruptPatch. Create( 'The patch is corrupted, incompatible or not a patch.'^M ); End; Procedure TWirePanel.SyncModules; Var i : Integer; Begin FModules.Clear; For i := 0 To ComponentCount - 1 Do If Components[ i] Is TCustomModule Then Begin FModules.Add( Components[ i]); With TCustomModule( Components[ i]) Do Name := UniqueName; End; End; // Protected Procedure TWirePanel.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin If Not FMouseDown And ( Button = mbLeft) Then Begin FMouseDown := True; GAnchor := Point( X, Y); GDistance := Point( 0, 0); DragStart( GAnchor ); DragMove ( GDistance); End; End; Procedure TWirePanel.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin If FMouseDown Then Begin DragMove( GDistance); GDistance.x := X - GAnchor.x; GDistance.y := Y - GAnchor.y; FMouseDown := False; DragEnd( GDistance); End; End; Procedure TWirePanel.MouseMove( Shift: TShiftState; X, Y: Integer); // Override; Begin If FMouseDown Then Begin DragMove( GDistance); GDistance.x := X - GAnchor.x; GDistance.y := Y - GAnchor.y; DragMove( GDistance); End End; Procedure TWirePanel.DragStart( aPoint: TPoint); // Virtual; Begin End; Procedure TWirePanel.DragEnd( aPoint: TPoint); // Virtual; Begin SelectModulesInRect( Rect( GAnchor.x, GAnchor.y, GAnchor.x + aPoint.x, GAnchor.y + aPoint.y ) ); End; Procedure TWirePanel.DragMove( aPoint: TPoint); // Virtual; Var aDC : HDC; aRect : TRect; Begin aDC := GetDC( 0); With ClientOrigin Do IntersectClipRect( aDC, X, Y, X + ClientWidth, Y + ClientHeight); Try With aRect Do Begin Left := Self.ClientOrigin.x + GAnchor.x; Top := Self.ClientOrigin.y + GAnchor.y; Right := Left + aPoint.x; Bottom := Top + aPoint.y; If Left > Right Then Exchange( Left, Right); If Top > Bottom Then Exchange( Bottom, Top); End; DrawFocusRect( aDC, aRect); Finally ReleaseDC( 0, aDC); End; End; Procedure TWirePanel.SelectModulesInRect( aRect: TRect); Var i : Integer; Begin With aRect Do Begin If Left > Right Then Exchange( Left, Right); If Top > Bottom Then Exchange( Bottom, Top); End; For i := 0 To ControlCount - 1 Do If Controls[ i] Is TCustomModule Then With TCustomModule( Controls[ i]) Do Selected := RectanglesOverlap( aRect, Rect( Left, Top, Left + Width, Top + Height)); End; Procedure TWirePanel.DefineProperties( aFiler : TFiler ); // Override; Begin Inherited DefineProperties( aFiler); aFiler.DefineProperty( 'Connections', ReadConnections, WriteConnections, True); End; Procedure TWirePanel.WriteConnections( aWriter: TWriter); Var i : Integer; Begin With aWriter Do Begin WriteListBegin; For i := 0 To WireCount - 1 Do WriteString( // New code, name based. Format( '%s.%s %s.%s', [ Source [ i].Owner.Name, Source [ i] .Name, Destination[ i].Owner.Name, Destination[ i] .Name ] ) ); WriteListEnd; End; End; Procedure TWirePanel.ReadConnections ( aReader: TReader); Begin ClearConnectionFixups; With aReader Do Begin ReadListBegin; While Not EndOfList Do AddConnectionFixup( ReadString); ReadListEnd; End; End; Procedure TWirePanel.Loaded; // Override; Var i : Integer; Begin Inherited; FixupConnections; { // This don't work ... // So the BringToFront & SendToBack calls are really needed // see @@@@1 remarks For i := 0 To ControlCount - 1 Do If Controls[ i] Is TWireOverlay Then With TWireOverlay( Controls[ i]) Do SetWindowPos( Handle, HWND_TOPMOST, 0, 0, 0, 0, SWP_NOMOVE + SWP_NOSIZE); } // Restack any modules inserted at design time. If HasParent Then For i := 0 To ControlCount - 1 Do If Controls[ i] Is TCustomModule Then Begin TCustomModule( Controls[ i]).Restack; Break; End; End; Function TWirePanel.IndexOfModule( aModule: TCustomModule): Integer; Begin Result := FModules.IndexOf( aModule); End; Function TWirePanel.ModuleCount: Integer; Begin If Assigned( FModules) Then Result := FModules.Count Else Result := 0; End; Function TWirePanel.WireCount: Integer; Begin If Assigned( FWireOverlay) Then Result := FWireOverlay.WireCount Else Result := 0; End; Procedure TWirePanel.Connect( aSource, aDestination: TConnector); Begin If Assigned( FWireOverlay) Then FWireOverlay.Connect( aSource, aDestination); End; Procedure TWirePanel.Notification( aComponent: TComponent; anOperation: TOperation); // Override; Var i : Integer; Begin Inherited; If aComponent Is TCustomModule Then Begin If anOperation = opInsert Then Begin i := IndexOfModule( TCustomModule( aComponent)); If i < 0 Then FModules.Add( aComponent); End Else If anOperation = opRemove Then Begin i := IndexOfModule( TCustomModule( aComponent)); If i >= 0 Then With FModules Do Begin Delete( i); Pack; End; End; End End; // Public Constructor TWirePanel.Create( anOwner: TComponent); // Override; Begin Inherited; ControlStyle := [ csAcceptsControls, csCaptureMouse, csClickEvents, csSetCaption, csDoubleClicks ]; ClearConnectionFixups; Width := 185; Height := 41; SnapX := 250; SnapY := 15; SnapActive := True; FModules := TList.Create; FWireOverlay := TWireOverlay.Create( Self); FWireOverlay.Parent := Self; End; Destructor TWirePanel.Destroy; // Override; Begin FModules.Free; If Assigned( FConnectionFixups) Then FConnectionFixups.Free; Inherited Destroy; End; Procedure TWirePanel.Save; // Virtual; Begin SaveAs( FFilename); End; Procedure TWirePanel.SaveAs( Const aFilename: String); // Virtual; Var Sb : TStream; St : TStream; Begin SyncModules; St := Nil; Sb := TMemoryStream.Create; Try With Sb Do Begin WriteComponentRes( '', Self); Seek( 0, 0); End; St := TFileStream.Create( aFilename, fmCreate); ObjectResourceToText( Sb, St); Finally If Assigned( St) Then St.Free; Sb.Free; End; FFilename := aFilename; End; Procedure TWirePanel.Load( Const aFilename: String); // Virtual; Var aWirePanel: TWirePanel; Sb : TStream; St : TStream; i : Integer; Begin Sb := TMemoryStream.Create; St := TFileStream.Create( aFilename, fmOpenRead); Try ObjectTextToResource( St, Sb); aWirePanel := TWirePanel.Create( Nil); With Sb Do Begin Seek( 0, 0); ReadComponentRes( aWirePanel); End; FreeModules; With aWirePanel Do Begin For i := 0 To ModuleCount - 1 Do With Module[ i] Do Clone( Self, Self, Point( Left, Top)); End; Finally Sb.Free; St.Free; End; FFilename := aFilename; End; Procedure TWirePanel.InvalidateWires; Begin FWireOverlay.InvalidateWires; End; Procedure TWirePanel.Disconnect( aConnector: TConnector); Begin If Assigned( FWireOverlay) Then FWireOverlay.Disconnect( aConnector); End; Function TWirePanel.CreateModule( aModuleClass: TCustomModuleClass): TCustomModule; Begin Result := aModuleClass.Create( Self); With Result Do Begin Parent := Self; BringToFront; Selected := True; UnselectPeers; End; End; Procedure TWirePanel.FreeModule( anIndex: Integer); Begin Module[ anIndex].Free; End; Procedure TWirePanel.FreeModules; Var i : Integer; Begin With FModules Do For i := Count - 1 Downto 0 Do FreeModule( i); End; Procedure TWirePanel.FreeSelectedModules; Var i : Integer; Begin With FModules Do For i := Count - 1 Downto 0 Do If Module[ i].Selected Then Begin Module[ i].DisConnect; FreeModule( i); End; End; Procedure TWirePanel.CopyModulesToClipBoard; Var i : Integer; aWirePanel : TWirePanel; aModule : TCustomModule; aSrcTag : LongInt; aDstTag : LongInt; Begin aWirePanel := TWirePanel.Create( Nil); Try With FModules Do For i := 0 To Count - 1 Do If Module[ i].Selected Then Begin With Module[ i] Do Begin aModule := Module[ i].Clone( aWirePanel, aWirePanel, Point( Left, Top)); Tag := Integer( aModule); MarkWires; End; End Else Module[ i].Tag := 0; For i := 0 To WireCount - 1 Do With Wire[ i] Do If FMarked Then Begin aSrcTag := ( FSource. Parent As TCustomModule).Tag; aDstTag := ( FDestination.Parent As TCustomModule).Tag; If ( aSrcTag <> 0) And ( aDstTag <> 0) Then Begin With aWirePanel Do Begin Connect( TCustomModule( aSrcTag).Components[ Self.Source [ i].ComponentIndex] As TConnector, TCustomModule( aDstTag).Components[ Self.Destination[ i].ComponentIndex] As TConnector ); End; End; End; ClipBoard.SetComponent( aWirePanel); Finally aWirePanel.Free; End; End; Procedure TWirePanel.PasteModulesFromClipBoard; Var aDummy : TComponent; aComponent: TComponent; aModule : TCustomModule; i : Integer; aSrcTag : Integer; aDstTag : Integer; Begin For i := 0 To ModuleCount - 1 Do Module[ i].Selected := False; aDummy := TComponent.Create( Application); aComponent := ClipBoard.GetComponent( aDummy, aDummy); Try If aComponent Is TWirePanel Then Begin With TWirePanel( aComponent) Do Begin For i := 0 To ModuleCount - 1 Do Begin With Module[ i] Do aModule := Clone( Self, Self, Point( Left, Top)); With aModule Do Begin Selected := True; Tag := Integer( Module[ i]); End; End; // Still working with TWirePanel( aComponent), not with Self ... For i := 0 To WireCount - 1 Do With Wire[ i] Do Begin aSrcTag := ( FSource. Owner As TCustomModule).Tag; aDstTag := ( FDestination.Owner As TCustomModule).Tag; If ( aSrcTag <> 0) And ( aDstTag <> 0) Then Self.Connect( TCustomModule( aSrcTag).Components[ FSource .ComponentIndex] As TConnector, TCustomModule( aDstTag).Components[ FDestination.ComponentIndex] As TConnector ); End; End; End Else ShowMessage( 'Clipboard has no modules.'); Finally aDummy.Free; Invalidate; End; End; Procedure TWirePanel.SelectAllModules; Var i : Integer; Begin For i := 0 To ModuleCount - 1 Do Module[ i].Selected := True; End; Procedure TWirePanel.InvertModuleSelection; Var i : Integer; Begin For i := 0 To ModuleCount - 1 Do With Module[ i] Do Selected := Not Selected; End; { ======== TCustomModule = Class( TCustomPanel) private FAnchor : TPoint; FDistance : TPoint; FCapturing : Boolean; FSelected : Boolean; FTresholdPast : Boolean; FTmpLeft : Integer; FTmpTop : Integer; FEditLabelMod : TEditLabel; FTitle : String; FBitmap : TBitmap; Public Property Selected: Boolean Read FSelected Write SetSelected; Property Title : String Read FTitle Write SetTitle; } Procedure TCustomModule.MarkWires; Var i : Integer; Begin If Owner Is TWirePanel Then Begin For i := 0 To ControlCount - 1 Do If Components[ i] Is TConnector Then TWirePanel( Owner).MarkWires( TConnector( Components[ i])); End; End; Function TCustomModule.UniqueName: String; // Virtual; Var i : Integer; S : String; Begin Result := ''; S := Copy( ClassName, 2, Length( ClassName)); With Owner Do For i := 0 To ComponentCount - 1 Do If FindComponent( Format( '%s%d', [ S, i])) = Nil Then Begin Result := Format( '%s%d', [ S, i]); Break; End; End; Procedure TCustomModule.AssignBitmap; // Virtual; Begin FBitmap := bmSkin; End; // Protected Procedure TCustomModule.MouseDown( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If Button = mbLeft Then Begin HandleSelection( ssCtrl In Shift); SetCapture( Handle); FCapturing := True; FTresholdPast := False; BeginMove( Point( X, Y)); End; SendToBack; // See @@@@1 remarks. End; Procedure TCustomModule.MouseMove( Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If FCapturing Then Begin If FTresholdPast Then MoveSelected( FDistance); FDistance := SubPoints( Point( X, Y), FAnchor); If Not FTresholdPast Then FTresholdPast := Distance( FDistance) > 8; If FTresholdPast Then Begin If ssCtrl In Shift Then Selected := True; MoveSelected( FDistance); End; End; End; Procedure TCustomModule.MouseUp( Button: TMouseButton; Shift: TShiftState; X, Y: Integer); // Override; Begin Inherited; If FCapturing Then Begin ReleaseCapture; FCapturing := False; If FTresholdPast Then Begin If HasParent Then Parent.DisableAlign; Try FinalMoveSelected( FDistance, ssCtrl In Shift) Finally If HasParent Then Parent.EnableAlign; End; End; SendToBack; // See @@@@1 remarks. End; End; Procedure TCustomModule.SetSelected( aValue: Boolean); Const Colors : Array[ Boolean] Of TColor = ( clSilver, clWhite); Begin If aValue <> FSelected Then Begin FSelected := aValue; If Assigned( FTitleLabel) Then With FTitleLabel Do Begin Color := Colors[ FSelected]; Transparent := Not Selected; End; End; End; Procedure TCustomModule.SetTitle( Const aValue: String); Begin If aValue <> FTitle Then Begin FTitle := aValue; If Assigned( FTitleLabel) Then FTitleLabel.Text := FTitle; End; End; Procedure TCustomModule.SetTitleLabel( aValue: TEditLabel); Begin FTitleLabel := aValue; If Assigned( FTitleLabel) And Not ( ComponentState * [ csDestroying, csLoading] = []) Then FTitleLabel.Caption := Title; End; // Protected Procedure TCustomModule.Snap( Var aPoint: TPoint); Begin If HasParent And ( parent Is TWirePanel) Then With TWirePanel( Parent) Do Begin If SnapActive Then Begin If SnapX <> 0 Then aPoint.x := (( aPoint.x + SnapX Div 2) Div SnapX) * SnapX; If SnapY <> 0 Then aPoint.y := (( aPoint.y + SnapY Div 2) Div SnapY) * SnapY; End; End; End; Procedure TCustomModule.Paint; // Override; Begin Inherited; Canvas.StretchDraw( Rect( 1, 1, Width - 2, Height - 2), FBitmap); End; Procedure TCustomModule.Loaded; // Override; Var p : TPoint; Begin Inherited; p := Point( Left, Top); Snap( P); Left := P.X; Top := P.Y; End; Procedure TCustomModule.ScrollSelfInView; Begin If HasParent And ( Parent Is TScrollingWinControl) Then TScrollingWinControl( Parent).ScrollInView( Self); End; Procedure TCustomModule.HandleSelection( CtrlKeyActive: Boolean); Begin If CtrlKeyActive Then Selected := Not Selected Else Begin If Not Selected Then UnselectPeers; Selected := True; End; BringToFront; End; Procedure TCustomModule.UnselectPeers; Var i : Integer; Begin If HasParent Then With Parent Do Begin For i := 0 To ControlCount - 1 Do If ( Controls[ i] Is TCustomModule) And ( Controls[ i] <> Self) Then TCustomModule( Controls[ i]).Selected := False; End End; Procedure TCustomModule.BeginMove( aPoint: TPoint); Begin FAnchor := aPoint; FDistance := Point( 0, 0); End; Procedure TCustomModule.Move( aPoint: TPoint); Var aDC : HDC; aRect : TRect; Begin If HasParent And Parent.HandleAllocated Then Begin With aRect Do Begin Left := ClientOrigin.x + aPoint.X; Top := ClientOrigin.y + aPoint.Y; Right := Left + Self.Width; Bottom := Top + Self.Height; End; aDC := GetDC( 0); With Parent Do With ClientOrigin Do IntersectClipRect( aDC, X, Y, X + ClientWidth, Y + ClientHeight); Try DrawFocusRect( aDC, aRect); Finally ReleaseDC( 0, aDC); End; End; End; Procedure TCustomModule.MoveSelected( aPoint: TPoint); Var i : Integer; Begin If HasParent Then With Parent Do For i := 0 To ControlCount - 1 Do If ( Controls[ i] Is TCustomModule) Then With TCustomModule( Controls[ i]) Do If Selected Then Move( aPoint); End; Procedure TCustomModule.FinalMoveSelected( aPoint: TPoint; CtrlKeyActive: Boolean); Const Magic = $00effefa; Var P : TPoint; i : Integer; aModule : TCustomModule; aCnt : Integer; Begin MoveSelected( FDistance); If HasParent Then Begin With Parent Do Begin aCnt := ControlCount; For i := 0 To aCnt - 1 Do Begin If Controls[ i] Is TCustomModule Then Begin aModule := TCustomModule( Controls[ i]); With aModule Do Begin If Selected Then Begin P := AddPoints( Point( Left, Top), aPoint); Snap( P); If CtrlKeyActive Then Begin // Ctrl drag - clone module & position it // (& do connections - later) Selected := False; Clone( Owner, Parent, P).Tag := Magic; End Else Begin // Otherwise a move to the (snapped) drag position. Left := P.X; Top := P.Y; End; End; End; End; End; ReStack; // Final house keeping. If CtrlKeyActive Then Begin For i := 0 To ControlCount - 1 Do Begin If Controls[ i] Is TCustomModule Then Begin With TCustomModule( Controls[ i]) Do Begin If Tag = Magic Then Begin Tag := 0; Selected := True; End; End; End; End; End; End; End; End; Procedure TCustomModule.InvalidateWires; Var aParent : TWinControl; Begin aParent := Parent; While Assigned( aParent) And Not ( aParent Is TWirePanel) Do aParent := aParent.Parent; If aParent Is TWirePanel Then TWirePanel( aParent).InvalidateWires; End; procedure TCustomModule.Notification( aComponent: TComponent; anOperation: TOperation); // Override; Var aParent : TWinControl; Begin Inherited; If ( anOperation = opRemove) And ( aComponent Is TConnector) Then Begin aParent := Parent; While Assigned( aParent) And Not ( aParent Is TWirePanel) Do aParent := aParent.Parent; If aParent Is TWirePanel Then TWirePanel( aParent).Disconnect( TConnector( aComponent)); End; End; Procedure TCustomModule.FixOwnership( aRoot, aControl: TWinControl); Var i : Integer; Begin If Assigned( aControl) And Assigned( aRoot) Then Begin With aControl Do Begin For i := 0 To ControlCount - 1 Do Begin With Controls[ i] Do Begin If ( Owner <> aRoot) And ( Parent = aRoot) Then Begin Owner.RemoveComponent( Controls[ i]); aRoot.InsertComponent( Controls[ i]); If Controls[ i] Is TWinControl Then FixOwnerShip( aRoot, TWinControl( Controls[ i])); End; End; End; End; End; End; // Public Constructor TCustomModule.Create( anOwner: TComponent); // Override; begin inherited; ControlStyle := [ csAcceptsControls, csCaptureMouse, csClickEvents, csDoubleClicks ]; AssignBitmap; FBitmap.Transparent := False; Width := 250; Height := 60; Name := ''; FTitle := Copy( Self.ClassName, 2, Length( Self.ClassName) - 1); DoubleBuffered := True; End; Function TCustomModule.Clone( anOwner: TComponent; aParent: TWinControl; anOffset: TPoint): TCustomModule; Var S : TStream; Begin // Make all children to be owned by the module // so they will be streamed out. FixOwnerShip( Self, Self); S := TMemoryStream.Create; Try S.WriteComponent( Self); S.Seek( 0, 0); Result := TCustomModule( S.ReadComponent( Nil)); anOwner.InsertComponent( Result); With Result Do Begin Parent := aParent; Left := anOffset.X; Top := anOffset.Y; End; Finally S.Free; End; End; // Public Procedure TCustomModule.Restack; Function DoSort( Item1, Item2: Pointer): Integer; Function SortModules( F1, F2: TCustomModule): Integer; Begin If F1.FTmpLeft < F2.FTmpLeft Then Result := -1 Else If F1.FTmpLeft > F2.FTmpLeft Then Result := 1 Else If F1.FTmpTop < F2.FTmpTop Then Result := -1 Else If F1.FTmpTop > F2.FTmpTop Then Result := 1 Else Result := 0; End; Begin Result := SortModules( TCustomModule( Item1), TCustomModule( Item2)); End; Var Modules : TList; i : Integer; CTop : Integer; CLeft : Integer; MRight : Integer; MBottom : Integer; Begin MRight := 0; MBottom := 0; If HasParent Then Begin Modules := TList.Create; Try With Parent Do Begin If parent Is TWirePanel Then With TWirePanel( Parent) Do If Not SnapActive // Bail out if not snapping, Then Exit; // stacking without snapping aint no good. For i := 0 To ControlCount - 1 Do Begin If Controls[ i] Is TCustomModule Then Begin With TCustomModule( Controls[ i]) Do Begin If Left < 0 Then FTmpLeft := 0 Else FTmpLeft := Left; If Top < 0 Then FTmpTop := 0 Else FTmpTop := Top; End; Modules.Add( Controls[ i]); End; End; End; With Modules Do Begin Sort( @ DoSort); CLeft := 0; CTop := 0; For i := 0 To Count - 1 Do Begin With TCustomModule( Items[ i]) Do Begin TabOrder := i; If FTmpLeft > CLeft Then Begin CLeft := FTmpLeft; CTop := 0; End; If FTmpTop < CTop Then FTmpTop := CTop; CTop := FTmpTop + Height; Left := FTmpLeft; Top := FTmpTop; MRight := Max( MRight , Left + Width); MBottom := Max( MBottom, Top + Height); End; End; End; Finally Modules.Free; End; With Parent Do Begin If HasParent Then Begin ClientWidth := Max( MRight , Parent.Width ); ClientHeight := Max( MBottom, Parent.Height); End; End; End; ScrollSelfInView; InvalidateWires; End; Procedure TCustomModule.Disconnect; Var i : Integer; Begin For i := 0 To ControlCount - 1 Do If Controls[ i] Is TConnector Then TConnector( Controls[ i]).Disconnect; End; { ======== TModule = class( TCustomModule) published property BiDiMode ; property Constraints ; property Enabled ; property Color ; property Ctl3D ; property Font ; property ParentBiDiMode ; property ParentColor ; property ParentCtl3D ; property ParentFont ; property ParentShowHint ; property PopupMenu ; property ShowHint ; property TabOrder ; property TabStop ; property Visible ; property OnContextPopup ; property OnEnter ; property OnExit ; property OnMouseDown ; property OnMouseMove ; property OnMouseUp ; property OnMouseWheel ; property OnMouseWheelDown ; property OnMouseWheelUp ; property OnResize ; Property Width ; Property Height ; Property Tag ; Property Title ; } { ======== TModuleButton = Class( TSpeedButton) Private FPageName : String; FModuleClass : TModuleClass; FModuleName : String; Public Property PageName : String Read FPageName; Property ModuleClass: TModuleClass Read FModuleClass; Property ModuleName : String Read FNoduleName; } Procedure TModuleButton.LoadGlyph; Var aFileName : String; Begin aFileName := ApplicationPath + 'bitmaps\' + ModuleName + '.bmp'; If FileExists( aFileName) Then With Glyph Do Begin LoadFromFile( aFileName); NumGlyphs := Width Div Height; End Else Caption := IntToStr( ModuleClass); End; Procedure TModuleButton.Initialize( Const aPageName: String; aModuleClass: TModuleClass; Const aModuleName: String); Begin FPageName := aPageName; FModuleClass := aModuleClass; FModuleName := aModuleName; LoadGlyph; End; { ======== TModuleButtonClick = Procedure( aSender: TObject; aModuleClass: TModuleClass) Of Object; TmoduleSelector = Class( TPageControl) Private FRegisteredModules : TList; FOnModuleButtonClick : TModuleButtonClick; FButtonsEnabled : Boolean; FAllowDuplicates : Boolean; Published Property OnModuleButtonClick : TModuleButtonClick Read FonModuleButtonClick Write FOnModuleButtonClick; Property ButtonsEnabled : Boolean Read FButtonsEnabled Write SetButtonsEnabled; Property AllowDuplicates : Boolean Read FAllowDuplicates Write FAllowDuplicates Default True; Private } Procedure TmoduleSelector.SetButtonsEnabled( aValue: Boolean); Var i : Integer; Begin If aValue <> FButtonsEnabled Then Begin FButtonsEnabled := aValue; With FRegisteredModules Do For i := 0 To Count - 1 Do TModuleButton( Items[ i]).Enabled := FButtonsEnabled; End; End; Function TmoduleSelector.AddPage( Const aName: String): TTabSheet; Begin Result := TTabSheet.Create( Self); With Result Do Begin Visible := True; Caption := aName; PageControl := Self; End; End; Function TmoduleSelector.PageButtonCount( Const aName: String): Integer; Var i : Integer; Begin Result := 0; If PageExists( aName) Then With PageByName( aName) Do For i := 0 To ControlCount - 1 Do If Controls[ i] Is TModuleButton Then Inc( Result); End; Function TmoduleSelector.PageExists( Const aName: String): Boolean; Begin Result := PageByName( aName) <> Nil; End; Function TmoduleSelector.PageByName( Const aName: String): TTabSheet; Var i : Integer; Begin Result := Nil; For i := 0 To PageCount - 1 Do If Pages[ i].Caption = aName Then Begin Result := Pages[ i]; Break; End; End; Function TmoduleSelector.FindModulePage( aModuleClass: TModuleClass): TTabSheet; Var i : Integer; Begin Result := Nil; With FRegisteredModules Do For i := 0 To Count - 1 Do With TModuleButton( Items[ i]) Do If ModuleClass = aModuleClass Then Begin Result := PageByName( PageName); Break; End; End; Function TmoduleSelector.FindModuleButton( aModuleClass: TModuleClass): TModuleButton; Var aPage : TTabSheet; i : Integer; Begin aPage := FindModulePage( aModuleClass); Result := Nil; If Assigned( aPage) Then With aPage Do Begin For i := 0 To ControlCount - 1 Do If Controls[ i] Is TModuleButton Then With TModuleButton( Controls[ i]) Do If ModuleClass = aModuleClass Then Begin Result := TModuleButton( Controls[ i]); Break; End; End; End; Procedure TmoduleSelector.DoModuleMouseDown( aSender: TObject; aButton: TMouseButton; aShift: TShiftState; X, Y: Integer); Begin If Assigned( FOnModuleButtonClick) And ( aSender Is TModuleButton) Then FOnModuleButtonClick( TModuleButton( aSender), TModuleButton( aSender).ModuleClass ); End; Procedure TmoduleSelector.FormatPage( aPage: TTabSheet); Var LastLeft : Integer; i : Integer; Begin Assert( Assigned( aPage), 'TModuleSelecteor.FormatPage : can''t format an unassigned page.' ); If PageButtonCount( aPage.Caption) = 0 Then Begin aPage.Free; If PageCount > 0 Then ActivePage := Pages[ 0]; End Else With aPage Do Begin LastLeft := 0; For i := 0 To ControlCount - 1 Do If Controls[ i] Is TModuleButton Then With TModuleButton( Controls[ i]) Do Begin Left := LastLeft; Inc( LastLeft, Width); End; End; End; { Protected } Procedure TmoduleSelector.Notification( aComponent: TComponent; anOperation: TOperation); // Override; Begin If aComponent Is TModuleButton Then Begin If anOperation = opInsert Then FRegisteredModules.Add ( aComponent) Else FRegisteredModules.Remove( aComponent); End; End; { Public } Constructor TmoduleSelector.Create( anOwner: TComponent); // Override; Begin Inherited Create( anOwner); FRegisteredModules := TList.Create; HotTrack := True; FAllowDuplicates := True; End; Destructor TmoduleSelector.Destroy; // Override; Begin Inherited Destroy; FRegisteredModules.Free; End; Procedure TmoduleSelector.RegisterModuleClass( Const aPageName: String; aModuleClass: TModuleClass; Const aModuleName: String); Var aPage : TTabSheet; aModuleButton : TModuleButton; Begin If Not FAllowDuplicates Then If Assigned( FindModuleButton( aModuleClass)) Then Raise ENoDuplicates. CreateFmt( 'A module type %d with name ''%s''is already present on page ''%s''', [ aModuleClass, aModuleName, FindModulePage( aModuleClass).Caption ] ); aPage := PageByName( aPageName); If Not Assigned( aPage) Then aPage := AddPage( aPageName); ActivePage := aPage; ActivePage := Pages[ 0]; aModuleButton := TModuleButton.Create( Self); With aModuleButton Do Begin Parent := aPage; Left := 0; Top := 0; Flat := True; Hint := aModuleName; ShowHint := True; Enabled := FButtonsEnabled; Initialize( aPageName, aModuleClass, aModuleName); OnMouseDown := DoModuleMouseDown; FormatPage( aPage); End; End; Procedure TmoduleSelector.UnregisterModuleClass( aModuleClass: TModuleClass); Var aModuleButton : TModuleButton; aPage : TTabSheet; Begin aModuleButton := FindModuleButton( aModuleClass); aPage := FindModulePage ( aModuleClass); If Assigned( aModuleButton) And Assigned( aPage) Then Begin aModuleButton.Free; FormatPage( aPage); // This will remove the page if it's empty. End; End; Initialization CreateBitmaps; RegisterClasses; Finalization UnRegisterClasses; FreeBitmaps; end.