jvdiagramshape.pas

East make Tray Icon in delphi

  EndMove;

  // If this shape is covering any smaller shapes then send it to the back,
  // so that we can get at the smaller ones
  if not Assigned(Parent) then
    Exit;
  for I := 0 to Parent.ControlCount - 1 do
  begin
    TempControl := Parent.Controls[I];
    if (TempControl <> Self) and
      (TempControl is TJvCustomDiagramShape) and
      TJvCustomDiagramShape(TempControl).CanProcessMouseMsg and
      InRect(TempControl.Left, TempControl.Top, BoundsRect) and
      InRect(TempControl.Left + TempControl.Width,
      TempControl.Top + TempControl.Height, BoundsRect) then
    begin
      // TempControl is not this one, it is a custom shape, that can process
      // mouse messages (eg not a connector), and is completely covered by
      // this control. So bring the convered control to the top of the z-order
      // so that we can access it.
      TempControl.BringToFront;
      Exit;
    end;
  end;
end;

//=== { TJvSizeableShape } ===================================================

constructor TJvSizeableShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FSizingMode := smNone;
  FSizeOrigin := Point(0, 0);
  FSizeRectHeight := 5;
  FSizeRectWidth := 5;
  FMinHeight := FSizeRectHeight;
  FMinWidth := FSizeRectWidth;
end;

procedure TJvSizeableShape.SetSelected(Value: Boolean);
begin
  if Value <> FSelected then
  begin
    inherited SetSelected(Value);
    // Force redraw to show sizing rectangles
    Invalidate;
  end;
end;

procedure TJvSizeableShape.Paint;
begin
  inherited Paint;
  if not Assigned(Parent) then
    Exit;
  DrawSizingRects;
end;

function TJvSizeableShape.GetSizeRect(SizeRectType: TJvSizingMode): TRect;
begin
  case SizeRectType of
    smTopLeft:
      Result := Bounds(0, 0, SizeRectWidth, SizeRectHeight);
    smTop:
      Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -
        (SizeRectWidth div 2), 0, SizeRectWidth, SizeRectHeight);
    smTopRight:
      Result := Bounds(ClientRect.Right - SizeRectWidth, 0,
        SizeRectWidth, SizeRectHeight);
    smLeft:
      Result := Bounds(0, ((ClientRect.Bottom - ClientRect.Top) div 2) -
        (SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);
    smRight:
      Result := Bounds(ClientRect.Right - SizeRectWidth,
        ((ClientRect.Bottom - ClientRect.Top) div 2) -
        (SizeRectHeight div 2), SizeRectWidth, SizeRectHeight);
    smBottomLeft:
      Result := Bounds(0, ClientRect.Bottom - SizeRectHeight,
        SizeRectWidth, SizeRectHeight);
    smBottom:
      Result := Bounds(((ClientRect.Right - ClientRect.Left) div 2) -
        (SizeRectWidth div 2), ClientRect.Bottom - SizeRectHeight,
        SizeRectWidth, SizeRectHeight);
    smBottomRight:
      Result := Bounds(ClientRect.Right - SizeRectWidth,
        ClientRect.Bottom - SizeRectHeight, SizeRectWidth, SizeRectHeight);
    smNone:
      Result := Bounds(0, 0, 0, 0);
  end;
end;

procedure TJvSizeableShape.DrawSizingRects;
var
  OldBrush: TBrush;
  SMode: TJvSizingMode;
begin
  if not FSelected or not CanProcessMouseMsg then
    Exit;
  with Canvas do
  begin
    // Draw the sizing rectangles
    OldBrush := TBrush.Create;
    try
      OldBrush.Assign(Brush);
      Brush.Style := bsSolid;
      Brush.Color := clBlack;
      Pen.Color := clBlack;
      for SMode := smTopLeft to smBottomRight do
        FillRect(GetSizeRect(SMode));
    finally
      Brush.Assign(OldBrush);
      OldBrush.Free;
    end;
  end;
end;

procedure TJvSizeableShape.CheckForSizeRects(X, Y: Integer);
const
  cCursors: array [TJvSizingMode] of TCursor =
    (crSizeNWSE, crSizeNS, crSizeNESW, crSizeWE, crSizeWE,
     crSizeNESW, crSizeNS, crSizeNWSE, crDefault);
var
  SMode: TJvSizingMode;
begin
  FSizingMode := smNone;
  if not Selected then
    Exit;

  for SMode := smTopLeft to smBottomRight do
    if InRect(X, Y, GetSizeRect(SMode)) then
    begin
      SizingMode := SMode;
      Break;
    end;
  Cursor := cCursors[SizingMode];
end;

procedure TJvSizeableShape.ResizeControl(X, Y: Integer);
var
  L, T, W, H, DeltaX, DeltaY: Integer;
begin
  L := Left;
  T := Top;
  W := Width;
  H := Height;
  DeltaX := X - FSizeOrigin.X;
  DeltaY := Y - FSizeOrigin.Y;
  // Calculate the new boundaries on the control. Also change FSizeOrigin to
  // reflect change in boundaries if necessary.
  case FSizingMode of
    smTopLeft:
      begin
        // Ensure that don't move the left edge if this would make the
        // control too narrow
        if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
        begin
          L := L + DeltaX;
          W := W - DeltaX;
        end;
        // Ensure that don't move the top edge if this would make the
        // control too short
        if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
        begin
          T := T + DeltaY;
          H := H - DeltaY;
        end;
      end;
    smTop:
      begin
        if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
        begin
          T := T + DeltaY;
          H := H - DeltaY;
        end;
      end;
    smTopRight:
      begin
        W := W + DeltaX;
        if (T + DeltaY >= 0) and (H - DeltaY > MinHeight) then
        begin
          T := T + DeltaY;
          H := H - DeltaY;
        end;
        FSizeOrigin.X := X;
      end;
    smLeft:
      begin
        if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
        begin
          L := L + DeltaX;
          W := W - DeltaX;
        end;
      end;
    smRight:
      begin
        W := W + DeltaX;
        FSizeOrigin.X := X;
      end;
    smBottomLeft:
      begin
        if (L + DeltaX >= 0) and (W - DeltaX > MinWidth) then
        begin
          L := L + DeltaX;
          W := W - DeltaX;
        end;
        H := H + DeltaY;
        FSizeOrigin.Y := Y;
      end;
    smBottom:
      begin
        H := H + DeltaY;
        FSizeOrigin.X := X;
        FSizeOrigin.Y := Y;
      end;
    smBottomRight:
      begin
        W := W + DeltaX;
        H := H + DeltaY;
        FSizeOrigin.X := X;
        FSizeOrigin.Y := Y;
      end;
    smNone: ;
  end;
  SetBounds(L, T, W, H);
end;

procedure TJvSizeableShape.MouseDown(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if (FSizingMode = smNone) or (Button <> mbLeft) or (ssShift in Shift) then
  begin
    // Do moving instead of sizing
    FSizingMode := smNone;
    inherited MouseDown(Button, Shift, X, Y);
    Exit;
  end;

  // If sizing then make this the only selected control
  UnselectAllShapes(Parent);
  BringToFront;
  { TODO : check on all Shapes selected }
  //  FSelected   := True;
  FSizeOrigin := Point(X, Y);
end;

procedure TJvSizeableShape.MouseMove(Shift: TShiftState; X, Y: Integer);
begin
  if Moving then
    inherited MouseMove(Shift, X, Y)
  else
  if (FSizingMode <> smNone) and (ssLeft in Shift) then
    ResizeControl(X, Y)
  else
    // Check if over a sizing rectangle
    CheckForSizeRects(X, Y);
end;

procedure TJvSizeableShape.MouseUp(Button: TMouseButton; Shift: TShiftState;
  X, Y: Integer);
begin
  if Button = mbLeft then
    FSizingMode := smNone;
  inherited MouseUp(Button, Shift, X, Y);
end;

procedure TJvSizeableShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  // Check that the control bounds are sensible. The control must be at least
  // as large as a sizing rectangle
  NoLessThan(ALeft, 0);
  NoLessThan(ATop, 0);
  NoLessThan(AWidth, FMinWidth);
  NoLessThan(AHeight, FMinHeight);
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

//=== { TJvTextShape } =======================================================

constructor TJvTextShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FAutoSize := True;
  FText := '';
  FFont := TFont.Create;
  FFont.OnChange := FontChange;
end;

destructor TJvTextShape.Destroy;
begin
  FreeAndNil(FFont);
  inherited Destroy;
end;

procedure TJvTextShape.RefreshText;
var
  I, Count: Integer;
  TempStr: string;
begin
  FMinHeight := FSizeRectHeight;
  FMinWidth := FSizeRectWidth;
  TempStr := '';
  Count := 1;
  if AutoSize and Assigned(Parent) then
  begin
    Canvas.Font := Font;
    for I := 1 to Length(FText) do
    begin
      if FText[I] = Lf then
      begin
        // Check the width of this line
        FMinWidth := Max([FMinWidth, Canvas.TextWidth(TempStr)]);
        TempStr := '';
        // Count the line feeds
        Inc(Count);
      end
      else
        TempStr := TempStr + FText[I];
    end;
    if Count = 1 then
      // In case there is only one line
      FMinWidth := Max([FMinWidth, Canvas.TextWidth(FText)]);
    // Calculate the height of the text rectangle
    FMinHeight := Max([FMinHeight, Canvas.TextHeight(FText) * Count]);
  end;
  SetBounds(Left, Top, FMinWidth, FMinHeight);
end;

{$IFDEF VisualCLX}
function TJvTextShape.GetText: TCaption;
begin
  Result := FText;
end;
{$ENDIF VisualCLX}

procedure TJvTextShape.SetText(const Value: TCaption);
begin
  if FText <> Value then
  begin
    FText := Value;
    RefreshText;
  end;
end;

procedure TJvTextShape.SetAutoSize(Value: Boolean);
begin
  if FAutoSize <> Value then
  begin
    FAutoSize := Value;
    RefreshText;
  end;
end;

procedure TJvTextShape.SetFont(Value: TFont);
begin
  FFont.Assign(Value);
end;

procedure TJvTextShape.FontChange(Sender: TObject);
begin
  RefreshText;
end;

{$IFDEF VisualCLX}
procedure TJvTextShape.SetParent(const AParent: TWidgetControl);
{$ENDIF VisualCLX}
{$IFDEF VCL}
procedure TJvTextShape.SetParent(AParent: TWinControl);
{$ENDIF VCL}
begin
  inherited SetParent(AParent);
  RefreshText;
end;

procedure TJvTextShape.Paint;
var
  TempRect: TRect;
begin
  if not Assigned(Parent) then
    Exit;
  Canvas.Font := Font;
  TempRect := ClientRect; // So can pass as a var parameter
  {$IFDEF VCL}
  DrawText(Canvas.Handle, PCaptionChar(FText), Length(FText), TempRect,
    DT_CENTER or DT_NOPREFIX or DT_WORDBREAK);
  {$ENDIF VCL}
  {$IFDEF VisualCLX}
  DrawText(Canvas, FText, Length(FText), TempRect,
    DT_CENTER or DT_NOPREFIX or DT_WORDBREAK);
  {$ENDIF VisualCLX}
  inherited Paint;
end;

procedure TJvTextShape.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  // Check that the control bounds are sensible. Note that this also works
  // if try to set Left, Top etc properties, as their access methods call
  // SetBounds().
  NoLessThan(AWidth, FMinWidth);
  NoLessThan(AHeight, FMinHeight);
  inherited SetBounds(ALeft, ATop, AWidth, AHeight);
end;

//=== { TJvBitmapShape } =====================================================

constructor TJvBitmapShape.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FImages := nil;
  FImageIndex := 0;
end;

procedure TJvBitmapShape.SetSelected(Value: Boolean);
begin
  if Value <> FSelected then
  begin
    inherited SetSelected(Value);
    // Force redraw to show focus rectangle
    Invalidate;
  end;
end;

procedure TJvBitmapShape.SetImages(Value: TImageList);
begin
  if Value <> FImages then
  begin
    FImages := Value;
    if FImages <> nil then