KBdemo: Delphi Version

{*****************************************************************************
* *
* KBdemo.dpr *
* KBdemoU.pas *
* *
* This program shows how to pan the contents of a virtual buffer through *
* a smaller window using the low-level keyboard handler. *
* *
*****************************************************************************}
unit KBdemoU;
interface
uses
 SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
 Forms, Dialogs, FGWin;
type
 TForm1 = class(TForm)
 procedure AppOnActivate(Sender: TObject);
 procedure AppIdle(Sender: TObject; var Done: Boolean);
 procedure FormActivate(Sender: TObject);
 procedure FormCreate(Sender: TObject);
 procedure FormPaint(Sender: TObject);
 procedure FormResize(Sender: TObject);
 procedure FormDestroy(Sender: TObject);
 end;
var
 Form1: TForm1;
implementation
{$R *.DFM}
const
 vbWidth = 640;
 vbHeight = 480;
var
 dc : hDC;
 hPal : hPalette;
 hVB : integer;
 cxClient, cyClient : integer;
 x, y : integer;
 xLimit, yLimit : integer;
 CanGoLeft, CanGoRight, CanGoUp, CanGoDown : boolean;
{*****************************************************************************
* *
* CheckForPanning() *
* *
* The CheckForPanning() function checks if any of the four arrow keys are *
* pressed, and if so, pans in that direction if possible. It is called from *
* the application's OnIdle event handler. *
* *
*****************************************************************************}
procedure CheckForPanning;
const
 KB_ESCAPE = 1;
 KB_LEFT = 75;
 KB_RIGHT = 77;
 KB_UP = 72;
 KB_DOWN = 80;
begin
 if (fg_kbtest(KB_LEFT) = 1) and CanGoLeft then
 begin
 if (x = xLimit) then CanGoRight := True;
 dec(x);
 fg_vbpaste(x,x+(vbWidth-1),y,y+(vbHeight-1),0,vbHeight-1);
 if (x = 0) then CanGoLeft := False;
 end
 else if (fg_kbtest(KB_RIGHT) = 1) and CanGoRight then
 begin
 if (x = 0) then CanGoLeft := True;
 inc(x);
 fg_vbpaste(x,x+(vbWidth-1),y,y+(vbHeight-1),0,vbHeight-1);
 if (x = xLimit) then CanGoRight := False;
 end
 else if (fg_kbtest(KB_UP) = 1) and CanGoUp then
 begin
 if (y = yLimit) then CanGoDown := True;
 dec(y);
 fg_vbpaste(x,x+(vbWidth-1),y,y+(vbHeight-1),0,vbHeight-1);
 if (y = 0) then CanGoUp := False;
 end
 else if (fg_kbtest(KB_DOWN) = 1) and CanGoDown then
 begin
 if (y = 0) then CanGoUp := True;
 inc(y);
 fg_vbpaste(x,x+(vbWidth-1),y,y+(vbHeight-1),0,vbHeight-1);
 if (y = yLimit) then CanGoDown := False;
 end
 else if (fg_kbtest(KB_ESCAPE) = 1) then
 begin
 x := 0;
 y := 0;
 fg_vbpaste(0,vbWidth-1,0,vbHeight-1,0,vbHeight-1);
 if (xLimit> 0) then CanGoRight := True;
 if (yLimit> 0) then CanGoDown := True;
 CanGoLeft := False;
 CanGoUp := False;
 end;
end;
{****************************************************************************}
procedure TForm1.AppOnActivate(Sender: TObject);
begin
 fg_realize(hPal);
 Invalidate;
end;
procedure TForm1.AppIdle(Sender: Tobject; var Done: Boolean);
begin
 CheckForPanning;
 Done := False;
end;
procedure TForm1.FormActivate(Sender: TObject);
begin
 fg_realize(hPal);
end;
procedure TForm1.FormCreate(Sender: TObject);
begin
 dc := GetDC(Form1.Handle);
 fg_setdc(dc);
 hPal := fg_defpal;
 fg_realize(hPal);
 fg_vbinit;
 hVB := fg_vballoc(vbWidth,vbHeight);
 fg_vbopen(hVB);
 fg_vbcolors;
 fg_showbmp('PORCH.BMP'+chr(0),0);
 x := 0;
 y := 0;
 CanGoRight := True;
 CanGoDown := True;
 CanGoLeft := False;
 CanGoUp := False;
 Application.OnActivate := AppOnActivate;
 Application.OnIdle := AppIdle;
end;
procedure TForm1.FormPaint(Sender: TObject);
begin
 fg_vbpaste(x,x+(vbWidth-1),y,y+(vbHeight-1),0,vbHeight-1);
end;
procedure TForm1.FormResize(Sender: TObject);
begin
 cxClient := ClientWidth;
 cyClient := ClientHeight;
 if (cxClient < vbWidth) then begin xLimit := vbWidth - cxClient; if (x> 0) then CanGoLeft := True;
 if (x < xLimit) then CanGoRight := True; end else begin xLimit := 0; CanGoLeft := False; CanGoRight := False; end; if (cyClient < vbHeight) then begin yLimit := vbHeight - cyClient; if (y> 0) then CanGoUp := True;
 if (y < yLimit) then CanGoDown := True; end else begin yLimit := 0; CanGoUp := False; CanGoDown := False; end; Invalidate; end; procedure TForm1.FormDestroy(Sender: TObject); begin fg_vbclose; fg_vbfree(hVB); fg_vbfin; DeleteObject(hPal); ReleaseDC(Form1.Handle,dc); end; end.