mmdesign.pas

一套及时通讯的原码

begin
   with FParentForm.Canvas do
   begin
      x1 := CompRect1.Left + CompRect1.Width;
      y1 := CompRect1.Top + CompRect1.Height div 2 - (CompRect1.Height+1) mod 2;
      x2 := CompRect2.Left;
      y2 := CompRect2.Top + CompRect2.Height div 2 - (CompRect2.Height+1) mod 2;

      if (CompRect1.Left + CompRect1.Width+2*FMargin > CompRect2.Left) and
         ((CompRect1.Top <> CompRect2.Top) or (CompRect1.Left > CompRect2.Left)) then
      begin
         if (CompRect1.Top > CompRect2.Top) then
         begin
            if (CompRect2.Top + CompRect2.Height + 2*FMargin > CompRect1.Top) then
            begin
               MoveTo(x1,y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),CompRect2.Top-FMargin);
               LineTo(x2-FMargin,CompRect2.Top-FMargin);
               LineTo(x2-FMargin,y2);
               LineTo(x2,y2);
            end
            else
            begin
               MoveTo(x1,y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),CompRect2.Top+CompRect2.Height+FMargin);
               LineTo(x2-FMargin,CompRect2.Top+CompRect2.Height+FMargin);
               LineTo(x2-FMargin,y2);
               LineTo(x2,y2);
            end;
         end
         else
         begin
            if (CompRect1.Top + CompRect1.Height+2*FMargin > CompRect2.Top) then
            begin
               MoveTo(x1,y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),CompRect2.Top+CompRect2.Height+FMargin);
               LineTo(x2-FMargin,CompRect2.Top+CompRect2.Height+FMargin);
               LineTo(x2-FMargin,y2);
               LineTo(x2,y2);
            end
            else
            begin
               MoveTo(x1,y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),y1);
               LineTo(Max(x1+FMargin,CompRect2.Left+CompRect2.Width+FMargin),CompRect2.Top-FMargin);
               LineTo(x2-FMargin,CompRect2.Top-FMargin);
               LineTo(x2-FMargin,y2);
               LineTo(x2,y2);
            end;
         end;
      end
      else
      begin
         MoveTo(x1,y1);
         LineTo(x2-FMargin,y1);
         LineTo(x2-FMargin,y2);
         LineTo(x2,y2);
      end;

      if ArrowOk then
      begin
         MoveTo(x2-2,y2-1); LineTo(x2-2,y2+2);
         MoveTo(x2-3,y2-2); LineTo(x2-3,y2+3);
      end;
   end;
end;

type
    TCustomControlWithCanvas = class(TCustomControl)
    public
       property Canvas;
    end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.DrawPorts(Comp: TComponent; InPort,OutPort: Boolean);
var
   R: TRect;
   x1,y1,x2,y2: integer;
   CompRect: TCompRect;
begin


   if (Comp is TControl) and not ControlVisible(Comp as TControl) then
      Exit;

   GetComponentPos(Comp, CompRect);
   with FParentForm.Canvas do
   begin
      Brush.Color := clNavy;
      y1 := CompRect.Top + (CompRect.Height div 2 - Griff div 2 - (CompRect.Height+1) mod 2);
      y2 := y1 + Griff;

      if InPort then
      begin
        x1 := CompRect.Left - Griff div 2;
        x2 := x1 + Griff;
        R := Rect(x1,y1,x2,y2);
        FillRect(R);
        {$IFDEF BUILD_ACTIVEX}
        if (Comp is TCustomControl) then
        with TCustomControlWithCanvas(Comp) do
        begin
           MapWindowPoints(FParentForm.Handle,Handle,R,2);
           Canvas.Brush.Color := clNavy;
           Canvas.FillRect(R);
        end;
        {$ENDIF}
      end;

      if OutPort then
      begin
        x1 := CompRect.Left + CompRect.Width + Griff div 2;
        x2 := x1 - Griff;
        R := Rect(x1,y1,x2,y2);
        FillRect(R);
        {$IFDEF BUILD_ACTIVEX}
        if (Comp is TCustomControl) then
        with TCustomControlWithCanvas(Comp) do
        begin
           MapWindowPoints(FParentForm.Handle,Handle,R,2);
           Canvas.Brush.Color := clNavy;
           Canvas.FillRect(R);
        end;
        {$ENDIF}
      end;
    end;
end;

{-- Port utils ----------------------------------------------------------}
type
   TInfoRec = packed record
    case Byte of
        0 : (InPort: WordBool; OutPort: WordBool);
        1 : (Long: LongInt);
   end;

{------------------------------------------------------------------------}
function GetPortInfo(Designer: TMMDesigner; i: Integer): TInfoRec;
begin
   if not Designer.FValidLists and not Designer.FRebuilding then
      Designer.RebuildLists;

   if Designer.FPortList = nil then
      Result.Long := 0
   else
      Result.Long := LongInt(Designer.FPortList[i]);
end;

{------------------------------------------------------------------------}
procedure SetPortInfo(Designer: TMMDesigner; i: Integer; const Info: TInfoRec);
begin
   Designer.FPortList[i] := Pointer(Info.Long);
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.RebuildLists;

   procedure AddConn(C1, C2: TComponent);
   begin
      FConnList.Add(C1);
      FConnList.Add(C2);
   end;

   procedure FindReferred(C : TComponent; Prop : Integer; PropType : TPropType);
   var
      i           : Integer;
      R           : TComponent;
      CInfo, RInfo: TInfoRec;
   begin
    for i := 0 to FParentComponent.ComponentCount - 1 do
    begin
       R := FParentComponent.Components[i];
       if C <> R then
       with TPropRec(PropList[Prop]) do
       if ((PropType = ptOutput) and (R is ClassTo)) or
          ((PropType = ptInput) and (R is ClassFrom)) then
          if not HasException(C,R,Prop) and
             (not Assigned(CheckProc) or
              ((PropType = ptOutput) and CheckProc(C,R)) or
              ((PropType = ptInput) and CheckProc(R,C))) then
             begin
                CInfo := GetPortInfo(Self,C.ComponentIndex);
                RInfo := GetPortInfo(Self,R.ComponentIndex);
                if PropType = ptOutput then
                begin
                   CInfo.OutPort := True;
                   RInfo.InPort  := True;
                   if GetPropValue(C,Prop) = R then
                      AddConn(C,R);
                end
                else
                begin
                   RInfo.OutPort := True;
                   CInfo.InPort  := True;
                   if GetPropValue(C,Prop) = R then
                      AddConn(R,C);
                end;
                SetPortInfo(Self,C.ComponentIndex,CInfo);
                SetPortInfo(Self,R.ComponentIndex,RInfo);
             end;
       end;
    end;
var
    i, j : Integer;
    C : TComponent;

begin
    FRebuilding := True;
    try
        if FPortList <> nil then
           FPortList.Clear
        else
           FPortList:= TList.Create;

        if FConnList <> nil then
           FConnList.Clear
        else
           FConnList := TList.Create;

        with FParentComponent do
        begin
           FPortList.Capacity := ComponentCount;
           for i := 0 to ComponentCount - 1 do
               FPortList.Add(nil);

           for i := 0 to ComponentCount - 1 do
           begin
              C := Components[i];
              for j := 0 to PropList.Count - 1 do
              if Allowed[j] <> nil then
              with TPropRec(PropList[j]) do
              if PropType = ptOutput then
              begin
                 if (C is ClassFrom) and CheckPropAvail(C,j,True) then
                     FindReferred(C,j,ptOutput)
              end
              else if PropType = ptInput then
              begin
                 if (C is ClassTo) and CheckPropAvail(C,j,True) then
                     FindReferred(C,j,ptInput)
              end;
           end;
        end;
    finally
        FRebuilding := False;
    end;
    FValidLists := True;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.Notification(AComponent: TComponent; Operation: TOperation);
begin
    inherited Notification(AComponent,Operation);
    FValidLists := False;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.DrawPaintBox;
var
   i: integer;
var
   Info     : TInfoRec;

   procedure DrawConn(C1, C2 : TComponent);
   var
      R1, R2 : TCompRect;
   begin
      GetComponentPos(C1, R1);
      GetComponentPos(C2, R2);
      DrawConnection(R1,R2,True);
   end;

   procedure DrawConnections;
   var
    i : Integer;
   begin
    for i := 0 to FConnList.Count div 2 - 1 do
        DrawConn(TComponent(FConnList[2*i]),TComponent(FConnList[2*i+1]));
   end;

begin
   if IsCompiling then exit;

   if PaintOk then FPaintOk := True;

   if (csDesigning in ComponentState) and FPaintOk and FActive and FVisible then
   with FParentComponent do
   begin
      RefreshForm(True,True);

      SetPen(FColor,FLineWidth,psSolid);

      RebuildLists;

      for i := 0 to ComponentCount-1 do
      begin
         Info := GetPortInfo(Self,i);
         { draw all input and output ports }
         DrawPorts(Components[i],Info.InPort,Info.OutPort);
      end;

      DrawConnections;

      if Adjusting and assigned(_RedrawTrack) then
         _RedrawTrack(True);

      inc(PaintCount);
      if PaintCount >= CreateCount then
      begin
         PaintOk := False;
         PaintCount := 0;
      end;

      FPaintOk := False;
   end
   else if PaintOk and FActive and Adjusting then
   begin
      if assigned(_RedrawTrack) then
         _RedrawTrack(True);
      PaintOK := False;
   end;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.TimerAction(Sender: TObject);
begin
   if AutoUpdate then DrawPaintBox;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.SetLineWidth(aValue: integer);
begin
   if (FLineWidth <> aValue) then
   begin
      FLineWidth := aValue;
      FPaintOk := True;
      DrawPaintBox;
   end;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.SetMargin(aValue: integer);
begin
   if (FMargin <> aValue) then
   begin
      FMargin := aValue;
      FPaintOk := True;
      DrawPaintBox;
   end;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.SetColor(aValue: TColor);
begin
   if (FColor <> aValue) then
   begin
      FColor := aValue;
      FPaintOk := True;
      DrawPaintBox;
   end;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.SetActive(aValue: Boolean);
begin
   if aValue then
   begin
      FPaintOk := True;
      DrawPaintBox;
   end
   else
   begin
      RefreshForm(True,True);
   end;
   FActive := aValue;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.SetUpdate(aValue: Boolean);
begin
   if aValue then
   begin
      Active := False;
      Active := True;
   end;
   FUpdate := False;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.FindTarget(Form: TForm; Wnd: HWND; var Pt: TPoint;
                                var TargetType: TPropType; var R: TRect): TComponent;
var
   i: Integer;

   function Check(C: TComponent): Boolean;
   begin
      if C = nil then
      begin
         Result := False;
         Exit;
      end;
      Result := True;

      if HasInput(C) and CheckInput(C,Pt,R) then
      begin
         TargetType := ptInput;
         Exit;
      end;

      if HasOutput(C) and CheckOutput(C,Pt,R) then
      begin
         TargetType := ptOutput;
         Exit;
      end;
      Result := False;
   end;

   procedure MapIt;
   begin
      MapWindowPoints(Wnd,Form.Handle,R,2);
      MapWindowPoints(Wnd,Form.Handle,Pt,1);
   end;

begin
   MapIt;
   with FParentComponent do
   for i := 0 to ComponentCount - 1 do
   if Check(Components[i]) then
   begin
      Result := Components[i];
      Exit;
   end;
   Result := nil;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.HasInput(C: TComponent): Boolean;
begin
   Result := GetPortInfo(Self,C.ComponentIndex).InPort;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.HasOutput(C: TComponent): Boolean;
begin
   Result := GetPortInfo(Self,C.ComponentIndex).OutPort;
end;

{-- TMMDesigner ---------------------------------------------------------}