長方形や円の図形を少しずつ移動していくような作業をするプログラムを書くには？ (ID:37161)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

新規フォームに
    Timer1: TTimer;
    PaintBox1: TPaintBox;
を貼付け
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
のイベントを追加して下記ソースを実行してみてください。

unit Unit1;

interface

uses
  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,
  Dialogs, ExtCtrls;

type
  //図形
  TMyShape = class
  private
    ax      : Integer;
    ay      : Integer;
  public
    Velocity: Integer;
    Angle   : Double;
    x       : Double;
    y       : Double;
    Color   : TColor;
    procedure CountUp();
    procedure Draw(aBMP:TBitmap); virtual;
  end;
  //四角
  TMyRect = class(TMyShape)
  public
    Width   : Integer;
    Height  : Integer;
    procedure Draw(aBMP:TBitmap); override;
  end;
  //丸
  TMyCircle = class(TMyShape)
  public
    r       : Integer;
    procedure Draw(aBMP:TBitmap); override;
  end;
  //フォーム
  TForm1 = class(TForm)
    Timer1: TTimer;
    PaintBox1: TPaintBox;
    procedure FormCreate(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private 宣言 }
    aMyRect   : array [0..10] of TMyRect;
    aMyCircle : array [0..10] of TMyCircle;
    fBitmap : TBitmap;
    procedure Timer1Timer(Sender: TObject);
    procedure PaintBox1Paint(Sender: TObject);
    procedure WMEraseBkGnd(var Msg: TMessage); message WM_ERASEBKGND;
  public
    { Public 宣言 }
  end;

var
  Form1: TForm1;

implementation

{$R *.dfm}

//少しカッコいい描画(オマケ)
procedure Darker(aBMP: TBitmap);
var
  p : PInteger;
  a,r,g,b:Byte;
  i,color: Integer;
begin
  aBMP.PixelFormat := pf32bit;
  p := aBMP.ScanLine[aBMP.Height-1];
  for i := 0 to aBMP.Width*aBMP.Height - 1 do
  begin
    r := p^;
    g := p^ shr 8;
    b := p^ shr 16;
    if r <> 0 then dec(r);
    if g <> 0 then dec(g);
    if b <> 0 then dec(b);
    p^ := RGB(r,g,b);
    inc(p);
  end;
end;

{ TMyShape }
procedure TMyShape.Draw(aBMP: TBitmap);
begin
  aBMP.Canvas.Pen.Color  := Color;
  aBMP.Canvas.Brush.Color:= Color;
  ax := Round(x) mod aBMP.Width;
  ay := Round(y) mod aBMP.Height;
  if ax < 0 then ax := aBMP.Width  + ax;
  if ay < 0 then ay := aBMP.Height + ay;
end;

procedure TMyShape.CountUp();
begin
  x := x + Velocity * Cos(Angle);
  y := y + Velocity * Sin(Angle);
end;

{ TMyRect }
procedure TMyRect.Draw(aBMP: TBitmap);
begin
  inherited;
  aBMP.Canvas.Rectangle(ax-Width  div 2,
                        ay-Height div 2,
                        ax+Width  div 2,
                        ay+Height div 2);
end;

{ TMyCircle }
procedure TMyCircle.Draw(aBMP: TBitmap);
begin
  inherited;
  aBMP.Canvas.Ellipse(ax-r,
                      ay-r,
                      ax+r,
                      ay+r);
end;

{ TForm1 }
procedure TForm1.FormCreate(Sender: TObject);
var i:Integer;
begin
  for i := 0 to Length(aMyRect) - 1 do
  begin
    aMyRect[i] := TMyRect.Create;
    aMyRect[i].x        := Random(ClientWidth);
    aMyRect[i].y        := Random(ClientHeight);
    aMyRect[i].Width    := 10 + Random(20);
    aMyRect[i].Height   := 10 + Random(20);
    aMyRect[i].Velocity := 1  + Random(3);
    aMyRect[i].Angle    := 2*Pi/360 * Random(360);
    aMyRect[i].Color    := RGB(Random(255),Random(255),Random(255));
  end;
  for i := 0 to Length(aMyCircle) - 1 do
  begin
    aMyCircle[i] := TMyCircle.Create;
    aMyCircle[i].x        := Random(ClientWidth);
    aMyCircle[i].y        := Random(ClientHeight);
    aMyCircle[i].r        := 10 + Random(20);
    aMyCircle[i].Velocity := 1  + Random(3);
    aMyCircle[i].Angle    := 2*Pi/360 * Random(360);
    aMyCircle[i].Color    := RGB(Random(255),Random(255),Random(255));
  end;
  fBitmap := TBitmap.Create;
  fBitmap.Width := PaintBox1.Width;
  fBitmap.Height:= PaintBox1.Height;

Timer1.Enabled  := True;
  Timer1.Interval := 1;
  Timer1.OnTimer  := Timer1Timer;
  PaintBox1.Align := alClient;
  PaintBox1.OnPaint:= PaintBox1Paint;
end;

procedure TForm1.FormDestroy(Sender: TObject);
var i:Integer;
begin
  Timer1.Enabled := False;
  for i := 0 to Length(aMyRect) - 1 do
    aMyRect[i].Free;
  for i := 0 to Length(aMyCircle) - 1 do
    aMyCircle[i].Free;
  fBitmap.Free;
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  fBitmap.Width  := PaintBox1.Width;
  fBitmap.Height := PaintBox1.Height;
  fBitmap.Canvas.Pen.Color  := clBlack;
  fBitmap.Canvas.Brush.Color:= clBlack;
  fBitmap.Canvas.Rectangle(0,0,fBitmap.Width,fBitmap.Height);
end;

procedure TForm1.PaintBox1Paint(Sender: TObject);
begin
  PaintBox1.Canvas.Draw(0,0,fBitmap);
end;

procedure TForm1.Timer1Timer(Sender: TObject);
var i:Integer;
begin
  fBitmap.Canvas.Pen.Color  := clBlack;
  fBitmap.Canvas.Brush.Color:= clBlack;
  fBitmap.Canvas.Rectangle(0,0,fBitmap.Width,fBitmap.Height);
  //カッコよく描画したい場合は↑をコメントアウトして
  //↓行を実行
  //Darker(fBitmap);
  for i := 0 to Length(aMyRect) - 1 do
  begin
    aMyRect[i].Draw(fBitmap);
    aMyRect[i].CountUp();
  end;
  for i := 0 to Length(aMyCircle) - 1 do
  begin
    aMyCircle[i].Draw(fBitmap);
    aMyCircle[i].CountUp();
  end;
  PaintBox1.Repaint;
end;

procedure TForm1.WMEraseBkGnd(var Msg: TMessage);
begin
  Msg.Result := 0;
end;

end.

←解決時は質問者本人がここをチェックしてください。

戻る