File Properties

Download File

Download

//==============================================================================
// Unit:       FFishTnk
//
// Purpose:    Main form for Fishtank demo app (RAD prototype)
//
// Copyright:  1997, Palladion Software
//==============================================================================
unit ffishtnk;

interface

uses
  Windows,
  Messages,
  SysUtils,
  Classes,
  Graphics,
  Controls,
  Forms,
  Dialogs,
  StdCtrls,
  DBCtrls,
  DBCGrids,
  DB,
  DBTables,
  ExtCtrls,
  Mask, Menus;

type

  TfrmFishtank = class(TForm)
    pnlControls: TPanel;
    tblBiolife: TTable;
    dtsBiolife: TDataSource;
    pnlFishtank: TPanel;
    pnlImage: TPanel;
    imgFish: TDBImage;
    tblBiolifeSpeciesNo: TFloatField;
    tblBiolifeCategory: TStringField;
    tblBiolifeCommon_Name: TStringField;
    tblBiolifeSpeciesName: TStringField;
    tblBiolifeLengthcm: TFloatField;
    tblBiolifeLength_In: TFloatField;
    tblBiolifeNotes: TMemoField;
    tblBiolifeGraphic: TGraphicField;
    lblCommon_Name: TLabel;
    edtCommon_Name: TDBEdit;
    lblLengthCm: TLabel;
    edtLengthCm: TDBEdit;
    navBiolife: TDBNavigator;
    tmrSwim: TTimer;
    chkSwim: TCheckBox;
    btnClearTank: TButton;
    pupFishOptions: TPopupMenu;
    itmRemove: TMenuItem;
    itmHorizontalSpeed: TMenuItem;
    itmVerticalSpeed: TMenuItem;

    procedure pnlFishtankDragOver( Sender, Source: TObject; X, Y: Integer;
      							   State: TDragState; var Accept: Boolean );
    procedure pnlFishtankDragDrop( Sender, Source: TObject; X, Y: Integer );
    procedure tmrSwimTimer(Sender: TObject);
    procedure chkSwimClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnClearTankClick(Sender: TObject);
    procedure itmRemoveClick(Sender: TObject);
    procedure pupFishOptionsPopup(Sender: TObject);
    procedure itmHorizontalSpeedClick(Sender: TObject);
    procedure itmVerticalSpeedClick(Sender: TObject);

  private

    FImages				: TList;
    FSelectedImage		: TImage;

  public
    { Public declarations }
  end;

var
  frmFishtank: TfrmFishtank;

implementation

{$R *.DFM}

type
	TImagePos = class
        img 		: TImage;
        signX 		: integer;
        signY		: integer;
    end;        

function RandomDelta( dMax : integer ) : integer;
begin
    Result := Random( ( 2 * dMax ) + 1 ) - dMax;
end;

procedure TfrmFishtank.pnlFishtankDragOver(Sender, Source: TObject; X, Y: Integer;
  State: TDragState; var Accept: Boolean);
begin
	Accept := ( Source is TDBImage );
end;

procedure TfrmFishtank.pnlFishtankDragDrop(Sender, Source: TObject; X, Y: Integer);

var
	imgPos		: TImagePos;

begin

	imgPos := TImagePos.Create;

    with imgPos do
    begin

    	signX := RandomDelta( 3 );
        signY := RandomDelta( 2 );

        img := TImage.Create( self );

        with img do
        begin
            Parent 		:= pnlFishtank;
            Stretch 	:= True;
            Width 		:= tblBiolifeLengthCm.AsInteger;
            Left		:= X;
            Top			:= Y;
            PopupMenu   := pupFishOptions;
        end;

        try
            with Source as TDBImage do
            begin
                img.Picture.Assign( Picture );
                img.Height := Trunc( Picture.Height
                					* img.Width / Picture.Width );
            end;
        except
            on Ex : Exception do
            begin
                ShowMessage( Ex.Message );
                img.Free;
                Free;
            end;
        end;

    end;	// with imgPos

    imgPos.img.Tag := FImages.Add( imgPos )

end;

procedure TfrmFishtank.tmrSwimTimer(Sender: TObject);

var
	i 			: integer;
    maxX 		: integer;
    maxY		: integer;

begin

	maxX := pnlFishtank.Width;
    maxY := pnlFishtank.Height;

	for i := 0 to FImages.Count - 1 do
    begin
    	with TImagePos( FImages[i] ) do
        begin
        	img.Top := img.Top + signY;

            if ( img.Top <= 0 )
            or ( img.Top + img.Height > maxY )
            or ( Random( 10 ) < 3 ) then
            begin
            	signY := - signY;
            end;

            img.Left := img.Left + signX;

            if ( img.Left <= 0 )
            or ( img.Left + img.Width > maxY )
            or ( Random( 100 ) < 5 )  then
            begin
            	signX := - signX;
            end;
        end;
    end;
end;

procedure TfrmFishtank.chkSwimClick(Sender: TObject);
begin
	tmrSwim.Enabled := (Sender as TCheckBox).Checked;
end;

procedure TfrmFishtank.FormCreate(Sender: TObject);
begin
	FImages := TList.Create;
end;

procedure TfrmFishtank.btnClearTankClick(Sender: TObject);

var
	i		: integer;

begin

	for i := FImages.Count - 1 downto 0 do
    begin
    	with TImagePos( FImages[i] ) do
        begin
        	img.Free;
            Free;
        end;
    end;

    FImages.Clear;
end;

procedure TfrmFishtank.pupFishOptionsPopup(Sender: TObject);
begin
	FSelectedImage := (Sender as TPopupMenu).PopupComponent as TImage;
end;

procedure TfrmFishtank.itmRemoveClick(Sender: TObject);

var
	ip		: TImagePos;

begin

	if ( FSelectedImage = Nil ) then
    	raise Exception.Create( 'No selected fish.' );

	ip := FImages[ FSelectedImage.Tag ];
    FImages.Remove( ip );

    ip.img.Free;
    ip.Free;
    FSelectedImage := Nil;
end;

procedure TfrmFishtank.itmHorizontalSpeedClick(Sender: TObject);

var
	newSpeed	: string;
	ip			: TImagePos;

begin

	if ( FSelectedImage = Nil ) then
    	raise Exception.Create( 'No selected fish.' );

    ip := FImages[ FSelectedImage.Tag ];
    newSpeed := IntToStr( ip.signX );

	if InputQuery( 'New speed:', 'Horizontal speed', newSpeed ) then
        ip.SignX := StrToIntDef( newSpeed, 0 );
end;

procedure TfrmFishtank.itmVerticalSpeedClick(Sender: TObject);

var
	newSpeed	: string;
	ip			: TImagePos;

begin

	if ( FSelectedImage = Nil ) then
    	raise Exception.Create( 'No selected fish.' );

    ip := FImages[ FSelectedImage.Tag ];
    newSpeed := IntToStr( ip.signY );

	if InputQuery( 'New speed:', 'Vertical speed', newSpeed ) then
        ip.signY := StrToIntDef( newSpeed, 0 );
end;

end.