dxflchrt.pas

业生产并行开发过程 工作流流程编辑器参考源码 采用dxflowchart编写

  Result := FObjects.Count;
end;

function TdxFcObject.GetPoint(const P: array of TPoint; X, Y, Cnt: Integer):
        Integer;
var
  I, Cur, Min, Mask, Start: Integer;
begin
  Result := 0;
  Min := $7FFFFFFF; I := Cnt shr 1;
  if Cnt = 2 then
    Mask := 7
  else
    Mask := 15;
  Inc(X, Owner.LeftEdge); Inc(Y, Owner.TopEdge);
  Start := Quadrant(X, Y) shl I + I;
  for I := Start to Start + Cnt do
  begin
    Cur := QDistance(X, Y, P[I and Mask]);
    if Cur < Min then
    begin
      Min := Cur;
      Result := I and Mask;
    end;
  end;
end;

function TdxFcObject.GetSelPoint(X, Y: Integer): Integer;
var
  P: array[0..7] of TPoint;
begin
  SelPoints(P);
  Result := GetPoint(P, X, Y, 2);
end;

function TdxFcObject.GetZOrder: Word;
begin
  Result := Word(Owner.FObjects.IndexOf(Self));
end;

function TdxFcObject.HasEdge: Boolean;
begin
  Result := (ShapeType = fcsRectangle) and (EdgeStyle <> 0);
end;

function TdxFcObject.HasImage: Boolean;
begin
  Result := (Owner.Images <> nil) and (ImageIndex >= 0) and (ImageIndex < Owner.Images.Count);
end;

function TdxFcObject.HasInUnion(AObject: TdxFcObject): Boolean;
var
  I: Integer;
begin
  Result := (AObject = nil) or (AObject = Self);
  if Result then Exit;
  for I := 0 to ObjectCount - 1 do
  begin
    Result := Objects[I].HasInUnion(AObject);
    if Result then Exit;
  end;
end;

function TdxFcObject.InRect(const R: TRect): Boolean;
begin
  Result := Visible;
  if Result then
  begin
    CreateRgn;
    Result := RectInRegion(FIntRgn, R);
  end;
end;

procedure TdxFcObject.Invalidate;
begin
  Owner.NeedRepaintObject(Self);
end;

procedure TdxFcObject.IsRepainted(Rgn: HRgn);
var
  R: TRect;
begin
  FRepainted := Visible;
  if not Visible then Exit;
  R := DisplayRect;
  ExtSelRect(R, Selected);
  FRepainted := RectVisible(Owner.Canvas.Handle, R) or (csPaintCopy in Owner.ControlState); {paul}
  if FRepainted and Opaque then
  begin
    CreateRgn;
    if FPaintRgn = 0 then FPaintRgn := CreateRectRgn(0, 0, 0, 0);
    CombineRgn(FPaintRgn, FExtRgn, FIntRgn, RGN_OR);
    FRepainted := CombineRgn(FPaintRgn, FPaintRgn, Rgn, RGN_DIFF) <> NULLREGION;
    if FRepainted then CombineRgn(Rgn, Rgn, FPaintRgn, RGN_OR);
    FRepainted := FRepainted or Selected;
  end;
end;

procedure TdxFcObject.Load(Stream: TStream);
var
  I: Integer;
  ObjData: TdxFcObjData;
begin
  Stream.ReadBuffer(ObjData, SizeOf(ObjData));
  with ObjData do
  begin
    SetBounds(Left, Top, Width, Height);
    EdgeStyle := Edge; BorderStyle := Border;
    HorzTextPos := HTPos; VertTextPos := VTPos;
    HorzImagePos := HIPos; VertImagePos := VIPos;
    Self.BkColor := BkColor; ShapeColor := ShColor;
    Self.Tag := Tag; ImageIndex := Image;
    ShapeType := Shape; ShapeWidth := ShWidth;
    ParentFont := ParFont; Self.Transparent := Transparent;
    while ObjCnt > 0 do
    begin
      I := 0; Dec(ObjCnt);
      Stream.ReadBuffer(I, SizeOf(Word));
      FObjects.Add(Pointer(I));
    end;
  end;
  LoadFont(Stream);
  Text := ReadStr(Stream);
  CustomData := ReadStr(Stream);
end;

procedure TdxFcObject.MakeVisible;
var
  R: TRect;
  LeftX, TopY: Integer;
begin
  Visible := True;
  if (RealWidth > Owner.ClientWidth) or (RealHeight > Owner.ClientHeight)
    then
    R := ClientRect
  else
    R := DisplayRect;
  LeftX := R.Left; TopY := R.Top;
  with Owner do
  begin
    if R.Right > ClientWidth then
      LeftX := LeftX + ClientWidth - R.Right;
    if LeftX < 0 then
      LeftX := 0;
    if R.Bottom > ClientHeight then
      TopY := TopY + ClientHeight - R.Bottom;
    if TopY < 0
      then TopY := 0;
    if (LeftX = R.Left) and (TopY = R.Top) then
      Exit;
    SetLeftTop(LeftEdge + R.Left - LeftX, TopEdge + R.Top - TopY);
  end;
end;

function TdxFcObject.Opaque: Boolean;
begin
  Result := not Transparent and (ShapeType <> fcsNone);
end;

procedure TdxFcObject.Paint;
var
  R: TRect;
begin
  if FRepainted then
  begin
    if Opaque and not (csPaintCopy in Owner.ControlState) then  // Fix: by Paulthen
      ExtSelectClipRgn(Owner.Canvas.Handle, FPaintRgn, RGN_OR);
    if ShapeType <> fcsNone then
      PaintFrame;
    R := ClientRect;
    if RectVisible(Owner.Canvas.Handle, R) or (csPaintCopy in Owner.ControlState) then {paul}
      if Assigned(Owner.OnDrawObject) then
        Owner.OnDrawObject(Owner, Self, R)
      else
        Owner.DefaultDrawObject(Self, R);
  end;
end;

procedure TdxFcObject.Paint_(cvs:TCanvas);
var
  R: TRect;
begin
//  if FRepainted then
  begin
    if Opaque and not (csPaintCopy in Owner.ControlState) then  // Fix: by Paulthen
      ExtSelectClipRgn(cvs.Handle, FPaintRgn, RGN_OR);
    if ShapeType <> fcsNone then
      PaintFrame_(cvs);
    R := ClientRect;
    if RectVisible(cvs.Handle, R) or (csPaintCopy in Owner.ControlState) then {paul}
      if Assigned(Owner.OnDrawObject) then
        Owner.OnDrawObject(Owner, Self, R)
      else
        Owner.DefaultDrawObject_(Self, R, cvs);
  end;
end;

procedure TdxFcObject.PaintFrame;
var
  Pt: TPoint;
  DC: HDC;
  Rgn: HRgn;
  R: TRect;
begin
  CreateRgn;
  DC := Owner.Canvas.Handle;
  if not Transparent then
  begin
    if HasEdge then
      Rgn := FPaintRgn
    else
      Rgn := FIntRgn;

    InitBrush(FBkBrush, BkColor);
    Pt := Point(0, 0); // by Paul
    if HasEdge then GetWindowOrgEx(DC, Pt); // by Paul
    if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul
      OffsetRgn(Rgn, Pt.X, Pt.Y); // by Paul
    FillRgn(DC, Rgn, FBkBrush.Handle);
    if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul
      OffsetRgn(Rgn, -Pt.X, -Pt.Y); // by Paul
  end; // by Paul
  if HasEdge then
  begin
    R := DisplayRect;
    DrawEdge(DC, R, EdgeStyle, BorderStyle);
  end
  else
  begin
    InitBrush(FShapeBrush, ShapeColor);
    FillRgn(DC, FExtRgn, FShapeBrush.Handle);
  end;
end;

procedure TdxFcObject.PaintFrame_(cvs:TCanvas);
var
  Pt: TPoint;
  DC: HDC;
  Rgn: HRgn;
  R: TRect;
begin
  CreateRgn;
  DC := cvs.Handle;
  if not Transparent then
  begin
    if HasEdge then
      Rgn := FPaintRgn
    else
      Rgn := FIntRgn;

    InitBrush(FBkBrush, BkColor);
    Pt := Point(0, 0); // by Paul
    if HasEdge then GetWindowOrgEx(DC, Pt); // by Paul
    if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul
      OffsetRgn(Rgn, Pt.X, Pt.Y); // by Paul
    FillRgn(DC, Rgn, FBkBrush.Handle);
    if (Pt.X <> 0) or (Pt.Y <> 0) then // by Paul
      OffsetRgn(Rgn, -Pt.X, -Pt.Y); // by Paul
  end; // by Paul
  if HasEdge then
  begin
    R := DisplayRect;
    DrawEdge(DC, R, EdgeStyle, BorderStyle);
  end
  else
  begin
    InitBrush(FShapeBrush, ShapeColor);
    FillRgn(DC, FExtRgn, FShapeBrush.Handle);
  end;
end;

procedure TdxFcObject.PaintImage(R: TRect);
var
  IR: TRect;
begin
  if Owner.Images = nil then Exit;
  IR := Rect(0, 0, Owner.Images.Width, Owner.Images.Height);
  if AdjustRect(IR, R, HorzImagePos, VertImagePos)
    then Owner.Images.Draw(Owner.Canvas, IR.Left, IR.Top, ImageIndex);
end;

procedure TdxFcObject.PaintImage_(R: TRect;cvs:TCanvas);
var
  IR: TRect;
begin
  if Owner.Images = nil then Exit;
  IR := Rect(0, 0, Owner.Images.Width, Owner.Images.Height);
  if AdjustRect(IR, R, HorzImagePos, VertImagePos)
    then Owner.Images.Draw(cvs, IR.Left, IR.Top, ImageIndex);
end;

procedure TdxFcObject.PaintText_(R: TRect;cvs:TCanvas);

  const
    Aligns: array[TdxFcHorzPos] of Word = (DT_LEFT, DT_CENTER, DT_RIGHT);
  var
    DC: HDC;
    Flags: Word;
    TR: TRect;

begin
  DC := cvs.Handle; TR := R;
  Flags := DT_EXPANDTABS or DT_WORDBREAK or Aligns[HorzTextPos];
  SelectObject(DC, RealFont.Handle);
  SetTextColor(DC, ColorToRGB(RealFont.Color));
  if VertTextPos <> fcvpUp then
  begin
    DrawText(DC, PChar(Text), -1, TR, Flags or DT_CALCRECT);
    AdjustRect(TR, R, HorzTextPos, VertTextPos);
  end;
  DrawText(DC, PChar(Text), -1, TR, Flags);
end;
procedure TdxFcObject.PaintText(R: TRect);

  const
    Aligns: array[TdxFcHorzPos] of Word = (DT_LEFT, DT_CENTER, DT_RIGHT);
  var
    DC: HDC;
    Flags: Word;
    TR: TRect;

begin
  DC := Owner.Canvas.Handle; TR := R;
  Flags := DT_EXPANDTABS or DT_WORDBREAK or Aligns[HorzTextPos];
  SelectObject(DC, RealFont.Handle);
  SetTextColor(DC, ColorToRGB(RealFont.Color));
  if VertTextPos <> fcvpUp then
  begin
    DrawText(DC, PChar(Text), -1, TR, Flags or DT_CALCRECT);
    AdjustRect(TR, R, HorzTextPos, VertTextPos);
  end;
  DrawText(DC, PChar(Text), -1, TR, Flags);
end;

procedure TdxFcObject.PutInFrontOf(Value: TdxFcObject);
var
  Z: Integer;
begin
  Z := Value.ZOrder;
  if Z < ZOrder then Inc(Z);
  SetZOrder(Z);
end;

function TdxFcObject.Quadrant(X, Y: Integer): Integer;
begin
  Result := Ord(X < RealLeft + RealWidth shr 1) shl 1 + Ord(Y >= RealTop + RealHeight shr 1);
  if Result > 1 then
    Result := Result xor 1;
end;

procedure TdxFcObject.RemoveFromUnion(AObject: TdxFcObject);
begin
  FObjects.Remove(AObject);
end;

procedure TdxFcObject.ResolveObjRefs;
var
  I: Integer;
begin
  for I := 0 to ObjectCount - 1 do
    FObjects[I] := Owner.Objects[Integer(FObjects[I])];
end;

procedure TdxFcObject.Save(Stream: TStream);
var
  I: Integer;
  W: Word;
  ObjData: TdxFcObjData;
begin
  with ObjData do
  begin
    Left := Self.Left; Top := Self.Top;
    Width := Self.Width; Height := Self.Height;
    Edge := EdgeStyle; Border := BorderStyle;
    HTPos := HorzTextPos; VTPos := VertTextPos;
    HIPos := HorzImagePos; VIPos := VertImagePos;
    BkColor := Self.BkColor; ShColor := ShapeColor;
    Tag := Self.Tag; Image := ImageIndex;
    Shape := ShapeType; ShWidth := ShapeWidth;
    ParFont := ParentFont; Transparent := Self.Transparent;
    ObjCnt := Word(ObjectCount);
  end;
  Stream.WriteBuffer(ObjData, SizeOf(ObjData));
  for I := 0 to ObjectCount - 1 do
  begin
    W := Objects[I].ZOrder;
    Stream.WriteBuffer(W, SizeOf(W));
  end;
  SaveFont(Stream);
  WriteStr(Stream, Text);
  WriteStr(Stream, CustomData);
end;

procedure TdxFcObject.SelectUnion;
var
  I: Integer;
begin
  Selected := True;
  with Owner do
    if not (fcoMultiSelect in Options) then Exit;
  for I := 0 to ObjectCount - 1 do
    Objects[I].SelectUnion;
end;

function TdxFcObject.SelList: TList;
begin
  Result := Owner.FSelObjects;
end;

procedure TdxFcObject.SelPoints(var Pts: array of TPoint);
var
  I: Integer;
begin
  for I := 2 to 4 do
    Pts[I].X := RealLeft + RealWidth - 1;
  for I := 6 to 8 do
    Pts[I and 7].X := RealLeft;
  for I := 0 to 2 do
    Pts[I].Y := RealTop;
  for I := 4 to 6 do
    Pts[I].Y := RealTop + RealHeight - 1;
  Pts[1].X := RealLeft + RealWidth shr 1;
  Pts[5].X := Pts[1].X;
  Pts[3].Y := RealTop + RealHeight shr 1;
  Pts[7].Y := Pts[3].Y;
end;

procedure TdxFcObject.SendToBack;
begin
  SetZOrder(0);
end;

procedure TdxFcObject.SetBkColor(Value: TColor);
begin
  if FBkColor <> Value then
  begin
    FBkColor := Value;
    if FBkBrush <> nil then FBkBrush.Color := Value;
    if not Transparent and (ShapeType <> fcsNone) then Owner.NeedRepaintObject(Self);
    Changed;
  end;
end;

procedure TdxFcObject.SetBorder(Value: Word);
begin