Problema con drag and drop y con OnPaint

[rounin]

Un pequeño ejemplo.
He lo hago una vez para aprobar algunas ideas.
Puede ser estara útil.

[martinartaza]

Acá en el trabajo ya están instaladas las librerías y pude verlo, el código que me diste está buenísimo es justo lo que necesito. Sin falta el miércoles a la tarde lo instalo en mi casa, tengo reunión con mi tutora de tesis el miércoles a la siesta.
Muchísimas gracias.

[martinartaza]

Hola rounin, me puedes facilitar un enlace o libro que hayas utilizado para realizar el código que me diste?
Desde ya muchas gracias.

[rounin]

No se.. Nada especial.
Codigo es practicamente puro OOP, nada mas.
Booch, GoF, VCL, etc.

[martinartaza]

Hola eh leido Booch y creo que la VCL uno nunca deja de sorprenderse. Estuve estudiando tu código y en principio se entiende lo que realiza, pero cuando quise hacer una pequeña modificación, para desgracia no me anda, estuve viéndolo y tratando de buscarla la vuelta y nada.
Te comento la modificación que realize.
Declaro 2 variables publicas.

Código Delphi [-]
    insertar2x2: Boolean; // Presiono en boton 2x2.
    cuantos2x2: integer;  // Para llevar los nombres de los bloques

Le agrego un botón que dice Agregar 2x2.
En el evento onclick del boton pongo la bandera en true.

Código Delphi [-]
procedure TForm1.BInsertar2x2Click(Sender: TObject);
begin
insertar2x2:= True;
end;

Y por ultimo modifico el evento MouseDown del TPaintBox, tratando que solo tome el nuevo camino cuando se presiono el botón, o sea creo que deberia seguir andando igual cuando no se presiono en el botón.

Código Delphi [-]
procedure TForm1.PBoxMouseDown(Sender: TObject; Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
var h: Boolean;
nombre2x2: string;
bl : TBlock;
begin
if not insertar2x2 then
   begin
   FRoot.DoMouseDown(Button, Shift, X, Y, h);
   PBox.Refresh;
   end
else
   begin
   nombre2x2:= 'Block 2 x 2 - ' + IntToStr(cuantos2x2);
   inc(cuantos2x2);
   bl := TBlock.Create;
   bl.Rect := Rect(x, y, x+61, y+51);
   bl.Name := nombre2x2;
   TContact.Create(bl, ckInput);
   TContact.Create(bl, ckInput);
   TContact.Create(bl, ckOutput);
   TContact.Create(bl, ckOutput);
   FRoot.Add(bl);
   insertar2x2:= false;
   end;
end;

Se inserta los bloques, pero ya no funciona a la hora de dibujar nuevas lineas y es justo ahí donde se me quemo un par de cables.

Rounin, te comento que me gusta mucho tu código, creo que sobre este tipo de cosas hay poca documentación, mientras que DB se tiene Millones de lugares donde leer y preguntar, pero sobre diseñar software tipo CAD (Diseño Asistido por Computadora), no hay mucho .

Desde ya muchas gracias.

[rounin]

Es mi error. He olvidado inicializar h en PBoxMouseDown
h := False; // !!!!!
FRoot.DoMouseDown(Button, Shift, X, Y, h);

[rounin]

Pienso que mejor hacer objecto para toda esquema.
Aproximamante así:

Código Delphi [-]
 
unit Schem;
interface
uses
  Windows, Classes, Messages, Controls, Graphics, Contnrs,
  Fig, Elem;
type
  TCreateFigureFunc = function({?}): TFigure of object;
  TScheme = class(TCustomControl)
  private
    FRoot: TFigure;
    //FMouseCaptured: Boolean;
    FAddNewFigureMode: Boolean;
    FCreateNewFigureFunc: TCreateFigureFunc;
    procedure DrawGrid;
  protected
    function CreateRoot: TFigure; virtual; abstract;
  public
    property Root: TFigure read FRoot;
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    {----------------------}
    procedure Paint; override;
    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;
    procedure KeyDown(var Key: Word; Shift: TShiftState); override;
    {----------------------}
    procedure AddNewFigureNextClick(ACreateNewFigureFunc: TCreateFigureFunc);
    procedure AddFigure(Figure: TFigure); virtual;
  end;
implementation
uses SysUtils;
{---------------------------------- TScheme -----------------------------------}
constructor TScheme.Create(AOwner: TComponent);
begin
  inherited;
  DoubleBuffered := True;
  ControlStyle := ControlStyle + [csOpaque];
  FRoot := CreateRoot;
end;
destructor TScheme.Destroy;
begin
  FRoot.Free;
  inherited;
end;
procedure TScheme.AddNewFigureNextClick(ACreateNewFigureFunc: TCreateFigureFunc);
begin
  FAddNewFigureMode := True;
  FCreateNewFigureFunc := ACreateNewFigureFunc;
end;
procedure TScheme.AddFigure(Figure: TFigure);
begin
  if FRoot is TFigureList then
    (FRoot as TFigureList).Add(Figure)
  else
    raise Exception.Create('You nee to override AddFigure');
end;
procedure TScheme.DrawGrid;
var i, j, H, W: Integer;
    R: TRect;
begin
  R := ClientRect;
  W := R.Right - R.Left;
  H := R.Bottom - R.Top;
  Canvas.Pen.Color := clBlack;
  for i := 0 to W div SNAP_SIZE do
    for j := 0 to H div SNAP_SIZE do
      Canvas.Pixels[i*SNAP_SIZE, j*SNAP_SIZE] := clBlack;
end;
procedure TScheme.Paint;
begin
  inherited;
  Canvas.Brush.Style := bsSolid;
  Canvas.Brush.Color := clWhite;
  Canvas.Pen.Mode := pmCopy;
  Canvas.Rectangle(ClientRect);
  DrawGrid;
  FRoot.DoDraw(Canvas);
end;
procedure TScheme.KeyDown(var Key: Word; Shift: TShiftState);
begin
  inherited;
  FRoot.DoKeyDown(Key, Shift);
  Invalidate;
end;
type
  THackFigure = class(TFigure);
procedure TScheme.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer);
var Handled: Boolean;
    NewFigure: TFigure;
    R: TRect;
begin
  inherited;
  Handled := False;
  if FAddNewFigureMode then
  begin
    if Assigned(FCreateNewFigureFunc) then
    begin
      NewFigure := FCreateNewFigureFunc;
      R := NewFigure.Rect;
      OffsetRect(R, X - R.Left, Y - R.Top);
      NewFigure.Rect := R;
      AddFigure(NewFigure);
    end;
    FAddNewFigureMode := False;
    Handled := True;
    THackFigure(FRoot).SetAgent(nil);
    Invalidate;
    Exit;
  end;
  FRoot.DoMouseDown(Button, Shift, X, Y, Handled);
  Invalidate;
end;
procedure TScheme.MouseMove(Shift: TShiftState; X, Y: Integer);
var cr: TCursor;
begin
  inherited;
  FRoot.DoMouseMove(Shift, X, Y, cr);
  Invalidate;
end;
procedure TScheme.MouseUp(Button: TMouseButton; Shift: TShiftState; X,
  Y: Integer);
begin
  inherited;
  FRoot.DoMouseUp(Button, Shift, X, Y, {FMouseCaptured}GlobalMouseCaptured);
  Invalidate;
end;
end.
 
//--------------------------------------------------------------
 
unit main;
interface
uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls, Buttons, 
  Fig, Elem, Schem;
type
  TBlockScheme = class;
  TForm1 = class(TForm)
    BNew2x2: TSpeedButton;
    procedure FormCreate(Sender: TObject);
    procedure BNew2x2Click(Sender: TObject);
  private
    FScheme: TBlockScheme;
    FLast2x2Index: Integer;
  public
    function CreateBlock2x2: TFigure;
  end;
  TBlockScheme = class(TScheme)
  private
    function GetRoot: TBlockList;
  protected
    function CreateRoot: TFigure; override;
  public
    property Root: TBlockList read GetRoot;
  end;
var
  Form1: TForm1;
implementation
{$R *.dfm}
{---------------------------- TBlockScheme ------------------------------------}
function TBlockScheme.CreateRoot: TFigure;
begin
  Result := TBlockList.Create;
end;
function TBlockScheme.GetRoot: TBlockList;
begin
  Result := inherited Root as TBlockList;
end;
{------------------------------------------------------------------------------}
procedure TForm1.FormCreate(Sender: TObject);
var bl: TBlock;
begin
  BNew2x2.GroupIndex := 1;
  BNew2x2.AllowAllUp := True;
  FScheme := TBlockScheme.Create(Self);
  FScheme.Parent := Self;
  FScheme.BoundsRect := Rect(30, 50, 650, 420);
end;
function TForm1.CreateBlock2x2: TFigure;
var bl: TBlock;
begin
  Inc(FLast2x2Index);
  bl := TBlock.Create;
  bl.Rect := Rect(420, 120, 480+1, 165+1);
  bl.Name := 'Test Block 3';
  TContact.Create(bl, ckInput);
  TContact.Create(bl, ckInput);
  TContact.Create(bl, ckOutput);
  TContact.Create(bl, ckOutput);
  bl.Name := 'Block 2x2 - ' + IntToStr(FLast2x2Index);
  Result := bl;
  BNew2x2.Down := False; 
end;
procedure TForm1.BNew2x2Click(Sender: TObject);
begin
  BNew2x2.Down := True;
  FScheme.AddNewFigureNextClick(CreateBlock2x2);
end;
end.