Chip 2001 October/Chip_2001-10_cd1.bin/zkuste/delphi/kompon/d123456/CHEMPLOT.ZIP/Misc/Shapeex.pas

Pascal/Delphi Source File | 2001-07-26 | 9.3 KB | 293 lines

unit Shapeex;

{-----------------------------------------------------------------------------
The contents of this file are subject to the Mozilla Public License Version 1.1 (the "License"); you may not use this file except in compliance with the License. You may obtain a copy of the License at

http://www.mozilla.org/MPL/MPL-1.1.html

Software distributed under the License is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY KIND, either expressed or implied. See the License for the specific language governing rights and limitations under the License.

The Original Code is: ShapeEx.pas, released 12 September 2000.

The Initial Developer of the Original Code is Mat Ballard.
Portions created by Mat Ballard are Copyright (C) 1999 Mat Ballard.
Portions created by Microsoft are Copyright (C) 1998, 1999 Microsoft Corp.
All Rights Reserved.

Contributor(s): Mat Ballard                 e-mail: [e-mail].

Last Modified: 05/25/2000
Current Version: 2.00

You may retrieve the latest version of this file from:

        http://Chemware.hypermart.net/

This work was created with the Project JEDI VCL guidelines:

        http://www.delphi-jedi.org/Jedi:VCLVCL

in mind.


Purpose:
This component is similar to TShape, but adds arrows and lines.

Known Issues:
-----------------------------------------------------------------------------}

interface

uses
  Classes, SysUtils,
{$IFDEF WINDOWS}
  WinTypes, WinProcs,
  Controls, Graphics
{$ENDIF}
{$IFDEF WIN32}
  Windows,
  Controls, Graphics
{$ENDIF}
{$IFDEF LINUX}
  Qt,
  QControls, QGraphics
{$ENDIF}
  ;

const
  TSHAPEEX_VERSION = 100;

type
  TShapeExType = (stArrowRight, stArrowLeft,
                  stArrowUp, stArrowDown,
                  stEllipse,
                  stLineHorz, stLineVert,
                  stRectangle, stRectangleRound,
                  stTriangleUp, stTriangleDown, stTriangleLeft, stTriangleRight
                  );
  {These are the extended shape types:}
  {}
  {stRectangle, stRectangleRound,}
  {stEllipse,}
  {stLineHorz, stLineVert,}
  {stArrowRight, stArrowLeft,}
  {stArrowUp, stArrowDown}

  TShapeEx = class(TGraphicControl)
  private
    { Private declarations }
    FShape: TShapeExType;
    FPen: TPen;
    FBrush: TBrush;
    procedure SetShape(Value: TShapeExType);
    procedure SetPen(Value: TPen);
    procedure SetBrush(Value: TBrush);
  protected
    procedure Paint; override;
    {This is the new Paint procedure that draws the various shapes on the canvas.}
    procedure StyleChange(Sender: TObject); dynamic;

  public
    { Public declarations }
    Constructor Create(AOwner: TComponent); override;
    {This is the normal constructor. It creates the Pen and Brush,
     initializes some properties, and sets the FBrush.OnChange event method.}
    Destructor Destroy; override;
    {This is the normal destructor. It frees the Pen and Brush.}
  published
    { Published declarations }
    Property Shape: TShapeExType read FShape write SetShape;
    {This is the shape to draw.}
    Property Brush: TBrush read FBrush write SetBrush;
    {This is the brush with which to draw the shape.}
    Property Pen: TPen read FPen write SetPen;
    {This is the pen with which to draw the shape.}

{Publish the Protected Events of the base class:}
    Property OnClick;
    Property OnDragDrop;
    Property OnEndDrag;
    Property OnMouseMove;
    Property OnDblClick;
    Property OnDragOver;
    Property OnMouseDown;
    Property OnMouseUp;
  end;

implementation

{------------------------------------------------------------------------------
    Procedure: TShapeEx.Create
  Description: standard constructor
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: creates the Pen and Brush, and sets the Position
 Known Issues:
 ------------------------------------------------------------------------------}
Constructor TShapeEx.Create(AOwner:TComponent);
begin
  inherited Create(AOwner);
  Width := 50;
  Height := 50;
  { Create Pen}
  FPen := TPen.Create;
  FPen.OnChange := StyleChange; { assign method to OnChange event }
  { Create Brush}
  FBrush := TBrush.Create;
  FBrush.OnChange := StyleChange; { assign method to OnChange event }
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.Destroy
  Description: standard destructor
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: frees the Pen and Brush
 Known Issues:
 ------------------------------------------------------------------------------}
Destructor TShapeEx.Destroy;
begin
  FPen.Free;
  FBrush.Free;
  inherited Destroy;
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.SetShape
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: sets the Shape Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TShapeEx.SetShape(Value: TShapeExType);
begin
  FShape := Value;
  Refresh;
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.SetPen
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: sets the Pen Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TShapeEx.SetPen(Value: TPen);
begin
  FPen.Assign(Value);
  Refresh;
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.SetBrush
  Description: standard property Set procedure
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: sets the Brush Property
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TShapeEx.SetBrush(Value: TBrush);
begin
  FBrush.Assign(Value);
  Refresh;
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.Paint
  Description: standard Paint procedure
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: draws the shape on the canvas
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TShapeEx.Paint;
var
  {Radius_X, Radius_Y: Integer;}
  PT: Integer; {pen thickness / 2}
begin
  Canvas.Pen := FPen;
  Canvas.Brush := FBrush;
  PT := Pen.Width div 2;
  case FShape of
    stRectangle: Canvas.Rectangle(PT,PT, Width-PT, Height-PT);
    stRectangleRound: Canvas.RoundRect(PT,PT, Width-PT, Height-PT, Width div 4, Height div 4);
    stEllipse: Canvas.Ellipse(PT, PT, Width-PT, Height-PT);
    stLineHorz:
      begin
        Canvas.MoveTo(0, Height div 2);
        Canvas.LineTo(Width-1, Height div 2);
      end;
    stLineVert:
      begin
        Canvas.MoveTo(Width div 2, 0);
        Canvas.LineTo(Width div 2, Height-1);
      end;
    stArrowLeft:
      begin
        Canvas.MoveTo(Width-1, Height div 2);
        Canvas.LineTo(PT, Height div 2);
        Canvas.LineTo(Height div 2, Height-1);
        Canvas.MoveTo(PT, Height div 2);
        Canvas.LineTo(Height div 2, 0);
      end;
    stArrowRight:
      begin
        Canvas.MoveTo(0, Height div 2);
        Canvas.LineTo(Width-PT, Height div 2);
        Canvas.LineTo(Width-1-(Height div 2), Height-1);
        Canvas.MoveTo(Width-PT, Height div 2);
        Canvas.LineTo(Width-1-(Height div 2), 0);
      end;
    stArrowUp:
      begin
        Canvas.MoveTo(Width div 2, Height-1);
        Canvas.LineTo(Width div 2, PT);
        Canvas.LineTo(0, Width div 2);
        Canvas.MoveTo(Width div 2, PT);
        Canvas.LineTo(Width-1, Width div 2);
      end;
    stArrowDown:
      begin
        Canvas.MoveTo(Width div 2, 0);
        Canvas.LineTo(Width div 2, Height-PT);
        Canvas.LineTo(0, Height-1-(Width div 2));
        Canvas.MoveTo(Width div 2, Height-PT);
        Canvas.LineTo(Width-1, Height-1-(Width div 2));
      end;
    stTriangleUp:
      Canvas.Polygon([Point(Width div 2, 0), Point(Width-1, Height-1), Point(0, Height-1)]);
    stTriangleDown:
      Canvas.Polygon([Point(0, 0), Point(Width-1, 0), Point(Width div 2, Height-1)]);
    stTriangleLeft:
      Canvas.Polygon([Point(0, Height div 2), Point(Width-1, 0), Point(Width-1, Height-1)]);
    stTriangleRight:
      Canvas.Polygon([Point(0, 0), Point(Width-1, Height div 2), Point(0, Height-1)]);
  end; {switch}
end;

{------------------------------------------------------------------------------
    Procedure: TShapeEx.StyleChange
  Description: standard change event handler
       Author: Mat Ballard
 Date created: 04/25/2000
Date modified: 04/25/2000 by Mat Ballard
      Purpose: forces a redraw
 Known Issues:
 ------------------------------------------------------------------------------}
procedure TShapeEx.StyleChange(Sender: TObject);
begin
  Refresh;
  { Invalidate;  erase and repaint the component }
end;

end.