Game Dengan Delphi 7

kali ini kita akan coba membuat game dengan delphi, game tersebuat adalah roller coaster.
pertama, buatlah form hingga seperti di bawah :

lalu copy kan listing di bawah kedalam kotak code :

unit U_RCoaster6;



interface

uses

  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls, ComCtrls, Grids, u_Splines, U_CoasterB, Menus,
  mmsystem, Spin, jpeg;

type
  TForm1 = class(TForm)
    PageControl: TPageControl;
    TrackPage: TTabSheet;
    CartPage: TTabSheet;
    Runpage: TTabSheet;
    FrictionBar: TTrackBar;
    Label1: TLabel;
    CartYEdt: TEdit;
    CHeightUD: TUpDown;
    CartXEdt: TEdit;
    CLengthUD: TUpDown;
    Label5: TLabel;
    Label6: TLabel;
    FrictionLbl: TLabel;
    MassEdt: TEdit;
    Label8: TLabel;
    Label9: TLabel;
    Label10: TLabel;
    Label11: TLabel;
    Label13: TLabel;
    Label12: TLabel;
    Label14: TLabel;
    XrptLbl: TLabel;
    YRptLbl: TLabel;
    ThetaCRptLbl: TLabel;
    ACRptLbl: TLabel;
    GCRptLbl: TLabel;
    VCRptLbl: TLabel;
    Label21: TLabel;
    AMinRptLbl: TLabel;
    GMinRptLbl: TLabel;
    VMinRptLbl: TLabel;
    AMaxRptLbl: TLabel;
    GMaxRptLbl: TLabel;
    VMaxRptLbl: TLabel;
    Label28: TLabel;
    Label29: TLabel;
    Label30: TLabel;
    VZeroEdt: TEdit;
    VZeroUD: TUpDown;
    Label15: TLabel;
    Runrptlbl: TLabel;
    DebugPage: TTabSheet;
    TimeloopBox: TCheckBox;
    LoopTimeLbl: TLabel;
    Label18: TLabel;
    Edit3: TEdit;
    MaxflyUD: TUpDown;
    DebugGrid: TStringGrid;
    DebugBox: TCheckBox;
    LoadTrackBtn: TButton;
    SaveTrackBtn: TButton;
    DesignBox: TCheckBox;
    NewTrackBtn: TButton;
    OpenDialog1: TOpenDialog;
    SaveDialog1: TSaveDialog;
    Constrainedbox: TCheckBox;
    PopupMenu1: TPopupMenu;
    Addcontrolpoint1: TMenuItem;
    Deletecontrolpoint1: TMenuItem;
    ThetaMinRptLbl: TLabel;
    ThetaMaxRptLbl: TLabel;
    Image1: TPaintBox;
    SimPage: TTabSheet;
    RunSoundbox: TCheckBox;
    Label2: TLabel;
    PosLbl: TLabel;
    GroupBox1: TGroupBox;
    Label19: TLabel;
    Label20: TLabel;
    GroupBox2: TGroupBox;
    Label22: TLabel;
    Label25: TLabel;
    Label4: TLabel;
    StepSecEdt: TEdit;
    StepsSecUD: TUpDown;
    Label3: TLabel;
    Label7: TLabel;
    FlyCRptLbl: TLabel;
    FlyMinRptLbl: TLabel;
    FlyMaxRptLbl: TLabel;
    XFirstUD: TUpDown;
    YFirstUD: TUpDown;
    XFirstEdt: TEdit;
    YFirstEdt: TEdit;
    FallSoundBox: TCheckBox;
    Edit1: TEdit;
    NbrCartsUD: TUpDown;
    Label16: TLabel;
    TimeScaleEdt: TEdit;
    TimeScaleUD: TUpDown;
    AspectBox: TCheckBox;
    VrXEdt: TEdit;
    VRYEdt: TEdit;
    GravityEdt: TEdit;
    PosLblBox: TCheckBox;
    AboutSheet: TTabSheet;
    Panel1: TPanel;
    ProgramIcon: TImage;
    ProductName: TLabel;
    Version: TLabel;
    Copyright: TLabel;
    Comments: TLabel;
    Panel2: TPanel;
    StartBtn: TButton;
    StopBtn: TButton;
    StepBtn: TButton;
    ResetBtn: TButton;
    Label23: TLabel;
    TrackScaleEdt: TEdit;
    TrackScaleUD: TUpDown;
    Label24: TLabel;
    SkylineEdt: TEdit;
    SkylineUD: TUpDown;
    Label26: TLabel;
    trackScaleBtn: TButton;
    StatusBar2: TStatusBar;
    Button2: TButton;
    Memo1: TMemo;
    procedure FormActivate(Sender: TObject);
    procedure StartBtnClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure StopBtnClick(Sender: TObject);
    procedure FrictionBarChange(Sender: TObject);
    procedure StepSecEdtChange(Sender: TObject);
    procedure VZeroEdtChange(Sender: TObject);
    procedure MassEdtChange(Sender: TObject);
    procedure ResetBtnClick(Sender: TObject);
    procedure StepBtnClick(Sender: TObject);
    procedure NewTrackBtnClick(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure DesignBoxClick(Sender: TObject);
    procedure SaveTrackBtnClick(Sender: TObject);
    procedure LoadTrackBtnClick(Sender: TObject);
    procedure ConstrainedboxClick(Sender: TObject);
    procedure CartYEdtChange(Sender: TObject);
    procedure CartXEdtChange(Sender: TObject);
    procedure SoundboxClick(Sender: TObject);
    procedure VredtExit(Sender: TObject);
    procedure VredtKeyPress(Sender: TObject; var Key: Char);
    procedure GravityEdtExit(Sender: TObject);
    {procedure XYFirstUDClick(Sender: TObject; Button: TUDBtnType);}
    procedure SkylineUDClick(Sender: TObject; Button: TUDBtnType);
    procedure XYFirstUDChangingEx(Sender: TObject; var AllowChange: Boolean;
      NewValue: Smallint; Direction: TUpDownDirection);
    procedure NbrCartsUDClick(Sender: TObject; Button: TUDBtnType);
    procedure FormPaint(Sender: TObject);
    procedure TimeScaleEdtChange(Sender: TObject);
    procedure XYFirstEdtChange(Sender: TObject);
    procedure GravityEdtKeyPress(Sender: TObject; var Key: Char);
    procedure PosLblBoxClick(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure FormResize(Sender: TObject);
    procedure trackScaleBtnClick(Sender: TObject);
    procedure Button2Click(Sender: TObject);

  public
    coaster:TCoaster;
    prevtime:float;
    debugrow:integer;
    directory, filename:string;
    paused:boolean;
    vmin,vmax,amin,amax,gmin,gmax,tmin,tmax,hmin,hmax:float;
    ybase:integer;
    procedure updatereportstats;
    procedure LoadCoaster(f:string);
    procedure LoadDisplaysFromCoaster;
    procedure CheckSaveModified;
  end;

var
  Form1: TForm1;

implementation

{$R *.DFM}

uses math;

const
  statfreq:float=0.0;  {update stats every seconds of scale run time}

{******************** Bikin Form ****************}
procedure TForm1.FormCreate(Sender: TObject);
begin
  directory:=extractfilepath(application.exename);
  filename:='default.coaster';
  savedialog1.initialdir:=directory;
  opendialog1.initialdir:=directory;
  randomize;
end;

{************************** TForm1 Diaktifkan ***************}
procedure TForm1.FormActivate(Sender: TObject);
begin
  windowstate:=wsmaximized;
  copyright.caption:='Copyright '+#169+' ';

  coaster:=tCoaster.create(image1);
  If fileexists(directory+filename) then loadcoaster(directory+filename);

  with DebugGrid do {Bikin Tab Debug}
  begin
    cells[0,0]:='Time';
    cells[1,0]:='Xval';
    cells[2,0]:='Yval';
    cells[3,0]:='Theta';
    cells[4,0]:='V';
    cells[5,0]:='Vx';
    cells[6,0]:='Vy';
    cells[7,0]:='a(tang.)';
    cells[8,0]:='a(norm.)';

    cells[9,0]:='g';
    cells[10,0]:='Dist';
    cells[11,0]:='Index';
  end;
  debugrow:=0;
  paused:=false; {Reset Paksa}
  startbtnclick(sender);
end;

{********************** Tombol Mulai ************}
procedure TForm1.StartBtnClick(Sender: TObject);
var
  loopcount, count, count2, freq:int64;
begin
   if not paused then resetbtnclick(sender);

   with pagecontrol do
   if (activepage<>DebugPage) and (activepage<>RunPage)
   then activepage:=RunPage;
   tag:=0;
   debugrow:=0;
   paused:=false;
   designbox.checked:=false;
   coaster.designmode:=false;
   DebugGrid.rowcount:=2;
   Debuggrid.fixedrows:=1;
   queryperformancefrequency(freq);
   queryperformancecounter(count);
   loopcount:=0;
   repeat
     stepbtnclick(sender) ;
     if loopcount mod 10 = 9 {Setiap 10 Step, cek interupt}
     then application.processmessages;
     inc(loopcount);
   until (tag<>0) or  (not coaster.cartready);
   if timeloopbox.checked then
   begin
     queryperformancecounter(count2);
     looptimelbl.caption:=format(' Avg loop time: %6.2n milliseconds',
                                 [(count2-count)/freq/loopcount*1e3]);
   end;
  end;

{********************* Tombol Reset ************}
procedure TForm1.ResetBtnClick(Sender: TObject);
var
  vertex:tVertex;
begin
  tag:=1;
  sleep(100);
  timescaleEdtChange(sender);
  designbox.checked:=false;

  coaster.init(maxflyud.position);  {Ketinggian Maximal}
  (* no need for these updates here?
  frictionbarchange(sender);
  gravityEdtExit(sender);
  stepsecEdtChange(sender);
  SoundBoxClick(sender);
  CartxEdtChange(sender);
  CartyEdtChange(sender);
  VzeroEdtChange(sender);
  MassEdtchange(sender);
  *)
  prevtime:=0;
  coaster.drawcart;
  paused:=false;
  amin:=1e6;   amax:=-1e6;
  vmin:=1e6;   vmax:=-1e6;
  gmin:=1e6;   gmax:=-1e6;
  tmin:=1e6;   tmax:=-1e6;
  hmin:=1e6;   hmax:=-1e6;
  updatereportstats; {zero out previous results}
  with coaster do
  begin
    vertex:=bspline.vertexnr(1);
    XFirstUD.position:=round(100*(vertex.x/width));
    YFirstUD.position:=round(100*(height-vertex.y)/height);
    vertex:=bspline.vertexnr(BSpline.numberofvertices);
    SkylineUD.position:=round(100*Yskyline/height);
    VrXedt.text:=format('%5.1f',[cxmax-cxmin]);
    VryEdt.text:=format('%5.1f',[cymax-cymin]);
  end;
end;

{******************* Tombol Stop *************}
procedure TForm1.StopBtnClick(Sender: TObject);
begin   paused:=true; tag:=1;  {set stop flag} end;

{************************ Tombol Step **************}
procedure TForm1.StepBtnClick(Sender: TObject);
begin
  with coaster do
  if cartready then
  begin
    cartready:=steptime;
    if not cartready then
    begin {cleanup values}
      a:=0;
      v:=0;
      prevtime:=time-statfreq; {Status Terakhir Paksa}
    end;
    UpdateReportStats;
  end
  else  beep;
end;

{****************** Tombol New Track ****************}
procedure TForm1.NewTrackBtnClick(Sender: TObject);
begin
   if coaster.modified then checksavemodified;
   coaster.free;
   coaster:=tCoaster.create(image1);
   LoadDisplaysFromCoaster;
   filename:='New.Coaster';
   designbox.checked:=true;
   coaster.designmode:=true;
   coaster.modified:=true;
end;

{*********************** Tombol Save Track ***********}
procedure TForm1.SaveTrackBtnClick(Sender: TObject);
var
  st:TFilestream;
begin
  savedialog1.initialdir:=directory;
  if filename<>'' then savedialog1.filename:=filename;
  if savedialog1.execute then
  begin
    st:=tfilestream.create(savedialog1.filename,fmCreate);
    coaster.savetoStream(st);
    filename:=extractfilename(savedialog1.filename);
    directory:=extractfilepath(savedialog1.filename);
    st.free;
    loadcoaster(savedialog1.filename);
  end;
end;

{******************** LoadTrackBtnClick *************}
procedure TForm1.LoadTrackBtnClick(Sender: TObject);

begin
  opendialog1.initialdir:=directory;
  if coaster.modified then checksavemodified;
  if opendialog1.execute then loadcoaster(opendialog1.FileName);
end;

procedure TForm1.LoadDisplaysFromCoaster;
  begin
    with coaster do
    begin
      frictionbar.position:=trunc(friction*1000);
      Gravityedt.text:=format('%5.1f',[gravity]);
      if timestep=0 then timestep:=0.1;
      StepssecUD.position:=round(1/timestep);
      CLengthUD.position:=round(cartx);
      CHeightUD.position:=round(carty);
      VZeroUD.position:=trunc(vzero);
      NbrCartsUD.position:=nbrcarts;
      MassEdt.text:=inttostr(trunc(mass));
      constrainedbox.checked:=constrained;
      timescaleUD.position:=round(timescale);
      runsoundbox.checked:=playrunsounds;
      fallsoundbox.checked:=playfallsounds;
    end;
  end;

{********************* UpdateReportStats *********}
procedure TForm1.UpdateReportStats;
var
  n,t:float;
  r:integer;
begin
  with coaster do
  begin
    runrptlbl.caption:=format(' %5.1n ',[time]);
    xrptlbl.caption:=format(' %4.1n ',[xval]);
    yrptlbl.caption:=format(' %4.1n ',[yval]);
    t:=-180/pi*theta;
    thetaCrptlbl.caption:=format(' %5.1n ',[t]);
    acrptlbl.caption:=format(' %5.1n ',[a]);
    gcrptlbl.caption:=format(' %5.1n ',[coaster.g]);
    vcrptlbl.caption:=format(' %5.1n ',[v]);
    n:=max(flyheight,0);
    FlyCrptlbl.caption:=format(' %5.1n ',[n]);
    if ((not onchain) and (rec.x        or (time=0) then
    {update max & min velocity, etc. diplays only while free coaasting}
    begin

      if t>tmax then tmax:=t;
      if t      thetaMinrptlbl.caption:=format(' %5.1n ',[tmin]);
      thetaMaxrptlbl.caption:=format(' %5.1n ',[tmax]);
      n:=a;
      If n>amax then amax:=n;
      if n      aminrptlbl.caption:=format(' %5.1n ',[amin]);
      amaxrptlbl.caption:=format(' %5.1n ',[amax]);

      n:=g;
      if n>gmax then gmax:=n;
      if n      gminrptlbl.caption:=format(' %5.1n ',[gmin]);
      if gmin<-3 then gminrptlbl.color:=clred
      else if gmin<-2 then gminrptlbl.color:=clyellow
      else gminrptlbl.color:=clAqua;
      gmaxrptlbl.caption:=format(' %5.1n ',[gmax]);
      if gmax>6 then gmaxrptlbl.color:=clred
      else if gmax>4.5 then gmaxrptlbl.color:=clyellow
      else gmaxrptlbl.color:=clAqua;

      n:=v;
      if n>vmax then vmax:=n;
      If n      vminrptlbl.caption:=format(' %5.1n ',[vmin]);
      vmaxrptlbl.caption:=format(' %5.1n ',[vmax]);

      n:=max(Flyheight,0);
      if n>hmax then hmax:=n;
      If n      Flyminrptlbl.caption:=format(' %5.1n ',[hmin]);
      Flymaxrptlbl.caption:=format(' %5.1n ',[hmax]);
      prevtime:=time;
    end;
    If debugbox.checked then
    with DebugGrid do
    begin
      inc(debugrow);
      r:=debugrow;
      if r>=rowcount then rowcount:=rowcount+1;
      cells[0,r]:=format('%5.2f',[Time]);
      cells[1,r]:=format('%5.2f',[Xval]);
      cells[2,r]:=format('%5.2f',[Yval]);
      cells[3,r]:=format('%5.2f',[Theta]);
      cells[4,r]:=format('%5.2f',[V]);
      cells[5,r]:=format('%5.2f',[Vx/scale]);
      cells[6,r]:=format('%5.2f',[Vy/scale]);
      cells[7,r]:=format('%5.2f',[a]);
      cells[8,r]:=format('%5.2f', [an/scale]); {a - normal}
      cells[9,r]:=format('%5.2f',[g]);
      cells[10,r]:=format('%5.2f',[distance]);
      cells[11,r]:=format('%5d',[rec.Index]);
      row:=rowcount-1;   {set cursor to last row}
    end;
  end;
end;



{************************** FormCloseQuery *****************}
procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: Boolean);
{If the coaster has been changed, then give user a chance to save before exiting}
begin
   tag:=1;  {set stopflag}
   if coaster.modified then checksavemodified;
   canclose:=true;
   playsound(nil,0,0);
end;

{******************** CartYEdtChnage **************}
procedure TForm1.CartYEdtChange(Sender: TObject);
begin
  if assigned(coaster) then
  if coaster.carty<>cheightUD.position then
  begin
    coaster.carty:=CheightUD.position;
  end;
end;

{****************** CartXEdtChange ***************}
procedure TForm1.CartXEdtChange(Sender: TObject);
begin
  If assigned(coaster) then
  if coaster.cartx<>clengthUD.position then
  begin
    coaster.cartx:=CLengthUD.position;
  end;
end;

{******************* FrictionBarChange **************}
procedure TForm1.FrictionBarChange(Sender: TObject);
var
  n:float;
begin
  with frictionbar do
  begin
    n:=position/1000;
    if n<>coaster.friction then
    begin
      coaster.setfriction(position/1000);
      {modified:=true;}
    end;
    frictionlbl.caption:=format(' %5.3n ',[position/1000]);
  end;
end;

{******************* GravityFEditExit ************}
procedure TForm1.GravityEdtExit(Sender: TObject);
var n:float;
begin
  n:=StrtoFloat(GravityEdt.text);
  coaster.SetGravity(n);
end;

{******************* MassEdtChange *************}
procedure TForm1.MassEdtChange(Sender: TObject);
var  n:float;
begin
  n:=strtointdef(massedt.text,1000);
  if coaster.mass <> n then
  begin
    coaster.setmass(n);
    {modified:=true;}
  end;
end;

{*********************** StepsSecEdtChange ***********}
procedure TForm1.StepSecEdtChange(Sender: TObject);
var
  n:float;
begin
   If assigned(coaster) then
   begin
     n:=1/stepssecUD.position;
     if stepssecUD.position<>round(1/coaster.timestep) then
     begin
       Coaster.settimestep(n);
       coaster.settimescale(coaster.timescale); {recalc  sleep time}
     end;
   end;
end;

{********************* VZeroEdtChange *************}
procedure TForm1.VZeroEdtChange(Sender: TObject);
var
  n:float;
begin
  if assigned(coaster) then
  begin
    n:=VZeroUD.position;
    if coaster.V<>n then
    begin
      Coaster.VZero:=n;
    end;
  end;
end;

{************** DesignBoxClick *****************}
procedure TForm1.DesignBoxClick(Sender: TObject);
begin
   coaster.designmode:=designbox.checked;
   coaster.drawpoints(100);
end;

{****************** CheckaveModified *********}
procedure TForm1.CheckSaveModified;
var
  r:integer;
begin
  r:=messagedlg('Save current coaster?', mtConfirmation,[mbyes,mbno,mbcancel],0);
  if r=mryes  then SaveTrackBtnClick(self)
  else if r=mrno then coaster.modified:=false;
end;

{************** LoadCoaster *************}
procedure TForm1.LoadCoaster(f:string);
 var
  st:TFilestream;
 begin
    if coaster.modified then checksavemodified;
    st:=tfilestream.create(f,fmopenRead);
    try
      coaster.loadfromstream(st);
      with coaster do
      begin
        directory:=extractfilepath(f);
        filename:=extractfilename(f);
        LoadDisplaysFromCoaster;
      end;
      finally st.free;
    end;
    resetbtnclick(self);
    coaster.modified:=false;
    caption:='Curent Coaster: '+ filename;
    paused:=true;  {just to prevent another reset at start}
 end;

 {**************ContrainedBoxClick ************}
procedure TForm1.ConstrainedboxClick(Sender: TObject);
begin
  If constrainedbox.checked <> coaster.constrained
  then coaster.setconstrained(constrainedbox.checked);
end;

{************************ CoundBoxClick *************}
procedure TForm1.SoundboxClick(Sender: TObject);
{set sound options}
begin
  coaster.playrunsounds:=Runsoundbox.checked;
  coaster.playfallsounds:=Fallsoundbox.checked
end;

{***************** VrFEdtExit ***************}
procedure TForm1.VredtExit(Sender: TObject);
var
  newx,newy:float;
  newcxmax,newcymax:float;
begin
  with coaster do
  if sender=VRXEdt then
  begin
    newx:=Strtofloat(VRXEdt.text);
    if aspectbox.checked
    then newy:=newx/(cxmax-cxmin)*(cymax-cymin)
    else newy:=cymax-cymin;
    newcxmax:=cxmin+newx;
    newcymax:=cymin+newy;
    VRYEdt.text:=format('%5.2f',[newy]);
  end
  else
  if sender=VRYEdt then
  begin
    newy:=Strtofloat(VRyEdt.text);
    if aspectbox.checked
    then newx:=newy/(cymax-cymin)*(cxmax-cxmin)
    else newx:=cxmax-cxmin;
    newcxmax:=cxmin+newx;
    newcymax:=cymin+newy;
    VRXEdt.text:=format('%5.2f',[newx]);
  end;

  with coaster do
  rescale(cxmin,newcxmax,cymin, newcymax,
             xmin,xmax,ymin,ymax);
end;

{*******************VRFEditKeyPress *****************}
procedure TForm1.VredtKeyPress(Sender: TObject; var Key: Char);
begin
  if key=#13 then
  begin
    VredtExit(Sender);
    key:=#00;
  end
  else if not (key in ['0'..'9','.']) then
  begin
   key:=#00;
   messagebeep(MB_ICONEXCLAMATION);
  end;
end;

{********************* TimescaleUDExit *************}
procedure TForm1.TimeScaleEdtChange(Sender: TObject);
begin
  if assigned(coaster) then coaster.Settimescale(TimeScaleUD.position);
end;

{********************XYFirstEdtChange *******************}
procedure TForm1.XYFirstEdtChange(Sender: TObject);
{Check and change coaster starting point}
var
  i:integer;
  dx,dy:float;
  vertex:TVertex;
begin
    if not assigned(coaster) then exit;
    vertex:=coaster.bspline.vertexnr(1);
    dx:=XFirstUD.position*(coaster.width)/100-vertex.x;
    dy:=((100-YFirstUD.position)*(coaster.height))/100-vertex.y;

    with coaster do
    if (xmin+dx>=0) and (xmax+dx<=width) and (ymin+dy>=0) and (ymax+dy<=height)
    then
    begin
      xmin:=xmin+dx;
      xmax:=xmax+dx;
      ymin:=ymin-dy;
      ymax:=ymax-dy;

      for i:=1 to bspline.numberofvertices do
      begin
        vertex:=bspline.vertexnr(i);
        vertex.x:=vertex.x+dx;
        vertex.y:=vertex.y+dy;
        bspline.changevertex(i,vertex.x,vertex.y);
      end;
      resetbtnclick(sender)
    end
    else messagebeep(MB_ICONEXCLAMATION);
 end;

{******************** SkylineUDClick *******************}
procedure TForm1.SkylineUDClick(Sender: TObject; Button: TUDBtnType);
{change skyline}
begin
  Coaster.YSkyline:=round(coaster.height*(SkylineUD.position)/100);
  coaster.invalidate;
end;

{********************* XYFirstUDChangingEx **************}
procedure TForm1.XYFirstUDChangingEx(Sender: TObject;
  var AllowChange: Boolean; NewValue: Smallint;
  Direction: TUpDownDirection);
{Check if start point change is valid}
var
  n:integer;
  d:float;
  vertex:TVertex;
begin
  allowchange:=false;
  vertex:=coaster.bspline.vertexnr(1);
  n:=newvalue;
  with coaster do
  if Sender=XfirstUD then
  begin
    d:=n*width/100-vertex.x;
    if (xmin+d>=0) and (xmax+d<=width)
    then allowchange:=true;
  end
  else if Sender=YFirstUD then
  begin
    d:=-((100-n)*height/100-vertex.y);
    if (ymin+d>=0) and (ymax+d<=height)
    then allowchange:=true;
  end ;
  if not allowchange then beep;
end;

procedure TForm1.NbrCartsUDClick(Sender: TObject; Button: TUDBtnType);
{Set nbr of carts in cart train}
begin
  coaster.nbrcarts:=NbrCartsUD.position;
end;

procedure TForm1.FormPaint(Sender: TObject);
{form will draw automaically handle all painting except for the coaster paintbox -
 call to coaster paint ensures that coaster image is redrawn when necessary}
begin  coaster.paintall(sender); end;

procedure TForm1.GravityEdtKeyPress(Sender: TObject; var Key: Char);
{make sure only valid numbers are entered}
begin
  if key=#13 then
  begin
    GravityEdtExit(sender);
    key:=#00;
  end
  else If not (key in['0'..'9','.']) then
  begin
    key:=#00;
    messagebeep(MB_ICONEXCLAMATION);
  end
end;

procedure TForm1.PosLblBoxClick(Sender: TObject);
{display mouse position in virtual world coordinates when over coaster }
begin  coaster.poslbl.visible:=PosLblBox.checked;  end;

procedure TForm1.Button1Click(Sender: TObject);
begin
  coaster.imagecopy.savetofile('coaster.bmp');
end;

procedure TForm1.FormResize(Sender: TObject);
begin
  pagecontrol.top:=clientheight-statusbar2.height-pagecontrol.height;
  with panel2 do
  begin
    top:= pagecontrol.top;
    left:=self.clientwidth-width;
  end;

  with image1 do
  begin
    height:=pagecontrol.top -10;
    width:=self.clientwidth;
  end;

  if coaster<>nil then
  begin
    loaddisplaysfromcoaster;
    {resetbtnclick(sender);}
  end;
end;

procedure TForm1.trackScaleBtnClick(Sender: TObject);
var n:float;
begin
  if coaster<>nil then
  with coaster do
  begin
    n:=trackscaleud.position/100;
    rescale(cxmin,cxmax,cymin,cymax,
            xmin,xmin+(xmax-xmin)*n,
            ymin,ymin+(ymax-ymin)*n);
    resetbtnclick(sender);
    trackscaleud.position:=100;
  end;
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  resetbtnclick(sender);
end;

end.

Selamat mencoba ^_^

Membuat Form Properties Text

seperti yang kita tau, sebuah text di dalam sebuah program word processor mempunyai properti yang kita bisa atur semau kita.. apakan ukurannya, tebal tipisnya maupun warnanya. kali ini kita buat simulasi properti text dengan delphi 7.

pertama buat form seperti di bawah :

kedua, ketikan code pada listing code hingga seperti berikut :

private

    { Private declarations }

  public

    { Public declarations }

  end;

var

  Form1: TForm1;

implementation

{$R *.dfm}

procedure TForm1.FormCreate(Sender: TObject);

begin

  nonaktif;

  bersih;

combobox1.Items:=screen.Fonts;

  combobox1.Text:='-PILIH FONTS-';

  combobox2.Text:='-PILIH SIZE-';

  combobox3.Text:='-PILIH BACK COLOR-';

  combobox4.Text:='-PILIH STYLE-';

end;

procedure TForm1.Button1Click(Sender: TObject);

begin

memo1.Text:=uppercase(Edit1.Text);

end;

procedure TForm1.Button2Click(Sender: TObject);

begin

memo1.Text:=lowercase(Edit1.Text);

end;

procedure TForm1.ComboBox1Change(Sender: TObject);

begin

memo1.Font.Name:=combobox1.Text;

end;

procedure TForm1.ComboBox2Change(Sender: TObject);

begin

memo1.Font.Size:=strtoint(combobox2.Text);

end;

procedure TForm1.ComboBox3Change(Sender: TObject);

begin

if combobox3.Text='Merah' then

  memo1.Color:=clred

  else if combobox3.Text='Biru' then

  memo1.Color:=clblue

  else memo1.Color:=clgreen;

end;

procedure TForm1.ComboBox4Change(Sender: TObject);

begin

if combobox4.Text='Bold' then

  memo1.Font.Style:=memo1.Font.Style+[fsBold]

  else if combobox4.Text='Italic' then

  memo1.Font.Style:=memo1.Font.Style+[fsItalic]

  else if combobox4.Text='Underline' then

  memo1.Font.Style:=memo1.Font.Style+[fsUnderline]

  else if combobox4.Text='StrikeOut' then

  memo1.Font.Style:=memo1.Font.Style+[fsStrikeOut]

  else

  memo1.Font.Style:=memo1.Font.Style-[fsBold,fsItalic,fsUnderline,fsStrikeOut];

end;

procedure TForm1.RadioButton1Click(Sender: TObject);

begin

memo1.Font.Color:=clred;

end;

procedure TForm1.RadioButton2Click(Sender: TObject);

begin

  memo1.Font.Color:=clgreen;

end;

procedure TForm1.RadioButton3Click(Sender: TObject);

begin

memo1.Font.Color:=clyellow;

end;

procedure TForm1.RadioButton4Click(Sender: TObject);

begin

memo1.Font.Color:=clpurple;

end;

procedure TForm1.RadioButton5Click(Sender: TObject);

begin

memo1.Font.Color:=clblack;

end;

procedure TForm1.RadioButton6Click(Sender: TObject);

begin

memo1.Font.Color:=clblue;

end;

tton5Click(Sender: TObject);

begin

application.Terminate;

end;

end.

Membuat Game Tangkep Pocong dengan Delphi 7

untuk membuat "Game Tangkep Pocong" ini kita membutuhkan beberapa item. yaitu :

1. gambar si pocong (tentunya)
2. sebuah label (caption : SCORE)
3. 2 buah tombol (tombol Start dan tombol stop)

ok, kita mulai saja.

Pertama, desain form hingga membentuk seperti ini

Kedua, masukan kode dibawah :

unit UPocong;

interface

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

type
  TForm1 = class(TForm)
    Label1: TLabel;
    Edit1: TEdit;
    Button1: TButton;
    Button2: TButton;
    Image1: TImage;
    Image2: TImage;
    Image3: TImage;
    Image4: TImage;
    Timer1: TTimer;
    procedure FormCreate(Sender: TObject);
    procedure Button1Click(Sender: TObject);
    procedure Button2Click(Sender: TObject);
  private
    { Private declarations }
  public
     procedure aktif;            //procedure bila sedang aktif
    procedure nonaktif;      //procedure bila sedang tidak aktif
    { Public declarations }
  end;

var
  Form1: TForm1;

implementation


{$R *.dfm}
 procedure tform1.aktif;
begin
Image1.enabled:=True;
Image2.enabled:=True;
Image3.enabled:=True;
Image4.enabled:=True;
Edit1.Enabled:=True;
Button2.enabled:=True;
Image4.Visible:=True;
Timer1.Enabled:=True;
end;

procedure tform1.nonaktif;
begin
Image1.enabled:=false;
Image2.enabled:=false;
Image3.enabled:=false;
Image4.enabled:=false;
Edit1.Enabled:=false;
Button2.enabled:=false;
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
nonaktif;
end;

procedure TForm1.Button1Click(Sender: TObject);
begin
aktif;
end;

procedure TForm1.Image1MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
Image1.left:=Random(Left);
Image1.Top:=Random(top);
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
close;
end;

procedure TForm1.Image2MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
Image2.left:=Random(Left);
Image2.Top:=Random(top);
end;

procedure TForm1.Image3MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
Image3.left:=Random(Left);
Image3.Top:=Random(top);
end;

procedure TForm1.Image4MouseMove(Sender: TObject; Shift: TShiftState; X,
  Y: Integer);
begin
Image4.left:=Random(Left);
Image4.Top:=Random(top);
end;

procedure TForm1.Image1Click(Sender: TObject);
begin
Image1.Visible:=False;
Edit1.text:=IntToStr(strtoint(Edit1.text)+20);
end;

procedure TForm1.Image2Click(Sender: TObject);
begin
Image2.Visible:=False;
Edit1.text:=IntToStr(strtoint(Edit1.text)+20);
end;

procedure TForm1.Image3Click(Sender: TObject);
begin
Image3.Visible:=False;
Edit1.text:=IntToStr(strtoint(Edit1.text)+20);
end;

procedure TForm1.Image4Click(Sender: TObject);
begin
Image4.Visible:=False;
Edit1.text:=IntToStr(strtoint(Edit1.text)+20);
end;

procedure TForm1.Edit1Change(Sender: TObject);
begin
if Edit1.Text='100' then
begin
  nonaktif;
  ShowMessage('anda menang');
end
end;

procedure TForm1.Timer1Timer(Sender: TObject);
begin
aktif;
ShowMessage('Game Over');
end;
end.

dan TARAAAA....!! jadi deh....
kalo masih error... silahkan posting aja disini... nanti tak benerin lagi... hehe