mmdesign.pas

一套及时通讯的原码

function TMMDesigner.HasPotentialInput(C: TComponent): Boolean;
begin
   Result := HasInput(C);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.HasPotentialOutput(C: TComponent): Boolean;
begin
   Result := HasOutput(C);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.CheckInput(C: TComponent; Pt: TPoint; var R: TRect): Boolean;
begin
   R := LeftGriff(C);
   if C is TControl then
   begin
      R.TopLeft     := ClientToClient(GetParentForm(C as TControl), (C as TControl).Parent, R.TopLeft);
      R.BottomRight := ClientToClient(GetParentForm(C as TControl), (C as TControl).Parent, R.BottomRight);
   end;
   Result   := PtInRect(R, Pt);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.CheckOutput(C: TComponent; Pt: TPoint; var R: TRect): Boolean;
begin
   R := RightGriff(C);
   if C is TControl then
   begin
      R.TopLeft     := ClientToClient(GetParentForm(C as TControl), (C as TControl).Parent, R.TopLeft);
      R.BottomRight := ClientToClient(GetParentForm(C as TControl), (C as TControl).Parent, R.BottomRight);
   end;
   Result := PtInRect(R, Pt);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.HasException(CompFrom: TComponent; CompTo: TComponent;
                      Index: Integer): Boolean;
var
   i         : Integer;
   Pt        : TPropType;
   CFrom, CTo: TClass;
   PName     : string;

begin
   with TPropRec(PropList[Index]) do
   begin
      if CompFrom = nil then
         CFrom := ClassFrom
      else
         CFrom := CompFrom.ClassType;

      if CompTo = nil then
         CTo := ClassTo
      else
         CTo := CompTo.ClassType;
      PName   := PropName;
      Pt      := PropType;
   end;

   for i := 0 to ExcPropList.Count - 1 do
   with TPropRec(ExcPropList[i]) do
   if (PropType = Pt) and (PropName = PName) and
      ((ClassFrom = nil) or CFrom.InheritsFrom(ClassFrom)) and
      ((ClassTo = nil) or CTo.InheritsFrom(ClassTo)) and
      ((@CheckProc = nil) or CheckProc(CompFrom,CompTo)) then
   begin
      Result := True;
      Exit;
   end;
   Result := False;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.FindProp(Pt: TPropType; CFrom: TComponent; CTo: TComponent;
                  StartFrom: Integer): Integer;
var
    i : Integer;

begin
   for i := StartFrom + 1 to PropList.Count - 1 do
   with TPropRec(PropList[i]) do
   if (PropType = Pt) then
    if Allowed[i] <> nil then
      if (CFrom = nil) or ((CFrom is ClassFrom) and CheckPropAvail(CFrom,i,PropType=ptOutput)) then
         if (CTo = nil) or ((CTo is ClassTo) and CheckPropAvail(CTo,i,PropType=ptInput)) then
            if not HasException(CFrom,CTo,i) then
            begin
               Result := i;
               Exit;
            end;

   Result := -1;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.FindRef(PropType: TPropType;C: TComponent;StartFrom: Integer): Integer;
begin
   if PropType = ptInput then
      Result := FindProp(ptInput,nil,C,StartFrom)
   else
      Result := FindProp(ptOutput,C,nil,StartFrom);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.FindRefs(PropType:TPropType;R,C:TComponent;StartFrom:Integer):Integer;
begin
   if PropType = ptInput then
      Result := FindProp(ptOutput,R,C,StartFrom)
   else
      Result := FindProp(ptInput,C,R,StartFrom);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.FindConnectProp(C1,C2: TComponent): Integer;
var
   i: Integer;
   FirstBusy : Integer;

begin
   FirstBusy := -1;
   i := FindProp(ptOutput,C1,C2,-1);
   while i <> -1 do
   begin
      with TPropRec(PropList[i]) do
      if not Assigned(CheckProc) or CheckProc(C1,C2) then
      begin
         if (GetPropValue(C1,i) = nil) then
         begin
            Result := i;
            Exit;
         end
         else if FirstBusy = -1 then
                 FirstBusy := i;
      end;
      i := FindProp(ptOutput,C1,C2,i);
   end;

   i := FindProp(ptInput,C1,C2,-1);
   while i <> -1 do
   begin
      with TPropRec(PropList[i]) do
      if not Assigned(CheckProc) or CheckProc(C1,C2) then
      begin
         if (GetPropValue(C2,i) = nil) then
         begin
            Result := i;
            Exit;
         end
         else if FirstBusy = -1 then
                 FirstBusy := i;
      end;
      i := FindProp(ptInput,C1,C2,i);
   end;
   Result := FirstBusy;
end;

{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.Connect(C1,C2: TComponent);
var
    i : Integer;
begin
    i := FindConnectProp(C1,C2);
    if i <> -1 then
    begin
       with TPropRec(PropList[i]) do
       if PropType = ptOutput then
          SetPropValue(C1,i,C2)
       else
          SetPropValue(C2,i,C1);
    end;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.CanConnect(C1,C2: TComponent): Boolean;
begin
   Result := FindConnectProp(C1,C2) <> -1;
end;

{ Out -> In }
{-- TMMDesigner ---------------------------------------------------------}
procedure TMMDesigner.GetConnected(C: TComponent; List: TList);
var
    i, j: Integer;
    R: TComponent;
begin
   List.Clear;
   for j := 0 to C.Owner.ComponentCount - 1 do
   if C.Owner.Components[j] <> C then
   begin
      R := C.Owner.Components[j];
      i := FindProp(ptOutput,C,R,-1);
      while i <> -1 do
      begin
         if (GetPropValue(C,i) = R) then Break;
         i := FindProp(ptOutput,C,R,i);
      end;

      if i <> -1 then
      begin
         List.Add(R);
         Continue;
      end;

      i := FindProp(ptInput,C,R,-1);
      while i <> -1 do
      begin
         if (GetPropValue(R,i) = C) then Break;

         i := FindProp(ptInput,C,R,i);
      end;

      if i <> -1 then
      begin
         List.Add(R);
         Continue;
      end;
   end;
end;

{ Removes reference from C to others }
{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.RemoveRef(C: TComponent; PropType: TPropType): Boolean;
var
   i: Integer;
begin
   i := FindRef(PropType,C,-1);
   while i <> -1 do
   begin
      with TPropRec(PropList[i]) do
      if (GetPropValue(C,i) <> nil) then
      begin { Ok, here it is }
         SetPropValue(C,i,nil);
         Result := True;
         Exit;
      end;
      i := FindRef(PropType,C,i);
    end;
    Result := False;
end;

{ Remove references from others to C }
{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.RemoveRefs(C: TComponent; PropType: TPropType): Boolean;
var
   i, j: Integer;
   R : TComponent;
begin
   for j := 0 to C.Owner.ComponentCount - 1 do
   begin
      R := C.Owner.Components[j];
      if R <> C then
      begin
         i := FindRefs(PropType,R,C,-1);
         while i <> -1 do
         begin
            with TPropRec(PropList[i]) do
            if (GetPropValue(R,i) = C) then
            begin
               SetPropValue(R,i,nil);
               Result := True;
               Exit;
            end;
            i := FindRefs(PropType,R,C,i);
         end;
      end;
   end;
   Result := False;
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.RemoveInput(C: TComponent): Boolean;
begin
   Result := RemoveRef(C,ptInput);
   if not Result then
      Result := RemoveRefs(C,ptInput);
end;

{-- TMMDesigner ---------------------------------------------------------}
function TMMDesigner.RemoveOutput(C: TComponent): Boolean;
begin
   Result := RemoveRef(C,ptOutput);
   if not Result then
      Result := RemoveRefs(C,ptOutput);
end;

{-- TMMDesigner ---------------------------------------------------------}
function  TMMDesigner.Allowed : TList;
var
    i : Integer;
begin
   if FAllowed.Count <> PropList.Count then
   begin
      FAllowed.Clear;
      FAllowed.Capacity := PropList.Count;
      for i := 0 to PropList.Count - 1 do
      if FProhibited.IndexOf(TPropRec(PropList[i]).PropGroup) = -1 then
         FAllowed.Add(Pointer(1))
      else
         FAllowed.Add(Pointer(0));
   end;
   Result := FAllowed;
end;

{------------------------------------------------------------------------}
procedure FreeProps; far;
var
   i: integer;
begin
   for i := 0 to PropList.Count-1 do
       TPropRec(PropList[i]).Free;
   PropList.Free;
   for i := 0 to PropList.Count-1 do
       TPropRec(ExcPropList[i]).Free;
   ExcPropList.Free;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.FormShow(Sender: TObject);

   procedure FillGroups;
   var
      i : Integer;
      Group : string;
   begin
      with GroupBox do
      begin
         Items.BeginUpdate;
         try
             Items.Clear;
             for i := 0 to PropList.Count - 1 do
             begin
                Group := TPropRec(PropList[i]).PropGroup;
                if Items.IndexOf(Group) = -1 then
                begin
                   Items.Add(Group);
                   Selected[Items.Count-1] := (Designer.FProhibited.IndexOf(Group) = -1);
                end;
             end;
         finally
            Items.EndUpdate;
         end;
      end;
   end;

begin
   btnHeight.Enabled := Designer.Active;
   ckbActive.Checked := Designer.Active;
   ckbAuto.Checked := Designer.AutoUpdate;
   ckbSound.Checked := Designer.Sound;
   FillGroups;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.CheckBoxClick(Sender: TObject);
begin
   if (Sender = ckbActive) then
   begin
      Designer.Active := ckbActive.Checked;
      btnHeight.Enabled := Designer.Active;
   end
   else if (Sender = ckbAuto) then
   begin
      Designer.AutoUpdate := ckbAuto.Checked;
   end
   else if (Sender = ckbSound) then
   begin
      Designer.Sound := ckbSound.Checked;
   end;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.btnHeightClick(Sender: TObject);
begin
   Adjusting := True;
   Close;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.FormHide(Sender: TObject);
var
   P :TPoint;
   R: TRect;

   procedure SetupProhibited;
   var
      i : Integer;
   begin
      Designer.FProhibited.Clear;
      with GroupBox do
      for i := 0 to Items.Count - 1 do
          if not Selected[i] then
             Designer.FProhibited.Add(Items[i]);

      { Force list rebuilding }
      Designer.FAllowed.Clear;
   end;

begin
   SetupProhibited;

   if Adjusting then
   with Designer do
   begin
      R := FParentForm.ClientRect;
      MapWindowPoints(FParentForm.Handle,0,R,2);
      ClipCursor(@R);

      GetCursorPos(P);
      DragPoint := Point(0,FParentForm.ScreenToClient(P).Y);

      DragDesigner := Designer;
      PaintOK := True;
   end;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.btnAllClick(Sender: TObject);
var
    i : Integer;
begin
    with GroupBox do
    for i := 0 to Items.Count - 1 do
        Selected[i] := True;
end;

{-- TMMDesignerForm -----------------------------------------------------}
procedure TMMDesignerForm.btnNoneClick(Sender: TObject);
var
    i : Integer;
begin
    with GroupBox do
    for i := 0 to Items.Count - 1 do
        Selected[i] := False;
end;


initialization
   {$IFNDEF WIN32}
   AddExitProc(FreeProps);
   {$ENDIF}
   PropList    := TList.Create;
   ExcPropList := TList.Create;
   DesignerForm := nil;
{$IFDEF WIN32}
finalization
   FreeProps;
{$ENDIF}
end.