Code:
unit Bingo1;
{$mode objfpc}{$H+}
interface
uses
Windows,
LCLIntf, LCLType, LCLProc,
SysUtils, Classes, Graphics,
Controls, Forms, Dialogs, Grids, ExtCtrls,
Buttons, Menus, Printers, PrintersDlgs, Types;
type
{ TFormMAIN }
TFormMAIN = class(TForm)
BtnSPACEBAR: TSpeedButton;
ImageBG: TImage;
MainMenu1: TMainMenu;
MenuItemOPSLAANJPG: TMenuItem;
MenuItemOPSLAANBMP: TMenuItem;
MenuItemPRINTlandscape: TMenuItem;
MenuItemSCHERMPRINT: TMenuItem;
MenuItemVERWIJDEREN: TMenuItem;
MenuItemOPSLAAN: TMenuItem;
MenuItemEXIT: TMenuItem;
MenuItemINFO: TMenuItem;
MenuItemNieuwSpel: TMenuItem;
MenuItemNieuwNummer: TMenuItem;
PanelBtnSPACEBAR: TPanel;
PanelBtnEXIT: TPanel;
PanelTijd: TPanel;
BtnEXIT: TSpeedButton;
PrintDialog1: TPrintDialog;
StringGrid1: TStringGrid;
PanelLastNum: TPanel;
Timer1: TTimer;
PanelReset: TPanel;
btnImageReset: TImage;
TimerDATUMTIJD: TTimer;
Panel1: TPanel;
//P1: TPanel;
//function FileExists_wc(AFileSpec: string): Boolean; //hier nier vermelden
//procedure Deletefiles_wc(AFileSpec: string); // hier niet vermelden
procedure BtnEXITClick(Sender: TObject);
procedure BtnSPACEBARClick(Sender: TObject);
procedure FormCreate(Sender: TObject);
procedure FormKeyPress(Sender: TObject; var Key: Char);
procedure FormResize(Sender: TObject);
procedure MenuItemOPSLAANJPGClick(Sender: TObject);
procedure MenuItemOPSLAANBMPClick(Sender: TObject);
procedure MenuItemEXITClick(Sender: TObject);
procedure MenuItemINFOClick(Sender: TObject);
procedure MenuItemNieuwNummerClick(Sender: TObject);
procedure MenuItemNieuwSpelClick(Sender: TObject);
procedure MenuItemPRINTlandscapeClick(Sender: TObject);
procedure PrintForm(centredOnPage: boolean; anOrientation: TPrinterOrientation);
procedure MenuItemVERWIJDERENClick(Sender: TObject);
procedure StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
procedure Timer1Timer(Sender: TObject);
procedure btnImageResetClick(Sender: TObject);
procedure TimerDATUMTIJDTimer(Sender: TObject);
procedure varbtnSluitClickEvent(Sender: TObject);
procedure varbtnBlijfClickEvent(Sender: TObject);
private
{ Private declarations }
public
{ Public declarations }
end;
type
TSoundPositions = record
text: string;
startpos: Integer;
endpos: Integer;
end;
TIniSettings = record
FontName: String;
Speech: Boolean;
Auto: Boolean;
NPM: Integer;
one: word;
two_nine: word;
Double: word;
Ding: word;
end;
var
FormMAIN: TFormMAIN;
//Order[0] =call count, Order[1..90]=order tiles to be played
Order: Array[0..90] of Integer;
//Plucked used by stringgrid to know how to draw a number.
Plucked: Array[1..90] of Boolean;
SoundPositions: Array[1..120] of TSoundPositions;
Self1, Self2, Ding1, Ding2: TSoundPositions;
IniSettings: TIniSettings;
implementation
{$R *.frm}
//------------Basic Functions/Procedures---------------//
// return sound start time in mSecs
function TimeToMsecs(s: string): Integer;
var ic,id, min,sec,ts: integer;
begin
ic := pos(':',s);
min := StrToInt(Copy(s, 1, ic-1));
id := pos('.',s);
sec := StrToInt(Copy(s, ic+1, id-ic-1));
ts := StrToInt(Copy(s, id+1, 1));
Result := min*60000 + sec*1000 + ts * 100;//minutes>ms
end;
//------------Startup --------------//
procedure TFormMAIN.FormCreate(Sender: TObject);
function used(N, COUNT: Integer):Boolean;
var i: integer;
begin
Result := False;
for i := 1 to COUNT do if Order[i] = N then Result := True;
end;
var i, x: integer;
begin
with StringGrid1 do
begin
for i := 0 to 89 do Cells[i mod 10, i div 10] := IntToStr(i+1);
end;
FormResize(Self);
FillChar(Plucked,90,False);
PanelLastNum.Caption := '--';
// setup random numbers
Randomize;
for i := 0 to 90 do Order[i] := 0;
for i := 1 to 90 do
begin
Repeat
x := Random(90) + 1;
Until not used(x, i - 1);
Order[i] := x
end;
//Setcursorposition
SetCursorPos(1000,600);
end;
procedure TFormMAIN.BtnSPACEBARClick(Sender: TObject);
var key: char;
begin
key := char(VK_SPACE);
if Order[0] = 90 then Timer1.Enabled := False
else FormKeyPress(Self, key);
end;
procedure TFormMAIN.FormKeyPress(Sender: TObject; var Key: Char);
var i: integer;
begin
case Key of
' ':
with Canvas do
begin
if Order[0] = 90 then Exit;
inc(Order[0]);
i := Order[Order[0]];
plucked[i] := True;
PanelLastNum.Caption := IntToStr(i);
Update;
StringGrid1.Cells[(i-1) mod 10, (i-1) div 10] := IntToStr(i);
end;
Char(VK_RETURN):
begin
if Timer1.Enabled then Timer1.Enabled := False
end;
end;
end;
procedure TFormMAIN.FormResize(Sender: TObject);
var X, Y: integer;
begin
with StringGrid1 do
begin
Y := FormMAIN.ClientHeight div RowCount;
X := FormMAIN.ClientWidth div (Colcount + 2);
DefaultRowHeight := Y - GridLineWidth;
DefaultColWidth := X - GridLineWidth;
Width := X * ColCount + GridLineWidth;
Height := Y * RowCount;
//********************************************************
Panel1.Left := Width + FormMAIN.BorderWidth;
Panel1.Width := X * 2;
Panel1.Height := Height;
//*******************************************************
PanelTijd.Width := 155 ;
PanelTijd.Height:= 40;
PanelTijd.Top := (Panel1.Height) - 320;
PanelTijd.Left:= (Panel1.Width) - 170;
//*******************************************************
PanelReset.Width := 120;
PanelReset.Height:= 65;
PanelReset.Top := (Panel1.Height) - 255;
PanelReset.Left:= (Panel1.Width) - 150;
//*******************************************************
PanelBtnSPACEBAR.Width:= 120;
PanelBtnSPACEBAR.Height:= 65;
PanelBtnSPACEBAR.Top:= (Panel1.Height) - 175; ;
PanelBtnSPACEBAR.Left:= (Panel1.Width) - 150;
BtnSPACEBAR.Caption:= 'SPEEL';
BtnSPACEBAR.Font.Color:= clRED;
BtnSPACEBAR.Font.Style:= [fsBold];
//*******************************************************
PanelBtnEXIT.Width:= 120;
PanelBtnEXIT.Height:= 52;
PanelBtnEXIT.Top:= (Panel1.Height) - 85; ;;
PanelBtnEXIT.Left:= (Panel1.Width) - 150;
//*******************************************************
PanelLastNum.Height := Y*2;
PanelLastNum.Font.Height := PanelLastNum.Height;
//*******************************************************
Canvas.Font.Name := Font.Name;
Canvas.Font.Height := DefaultRowHeight;
end;
end;
procedure TFormMAIN.MenuItemEXITClick(Sender: TObject);
begin
Application.Terminate;
end;
procedure TFormMAIN.MenuItemINFOClick(Sender: TObject);
begin
Application.MessageBox(''+#13+#13+
'Bingo-v1.0 [April 2008] werd gemaakt via DELPHI door Martin ter Wee[NL].'
+#13+ '' +#13+
'Bingo-v2.0 [Juni 2015] is een aangepaste versie, via CODETYPHON door Leo Seghers[BE]'
+#13+
'E-Mail: leo.seghers@telenet.be '
+#13+
'Dit is geprogrammeerd in "Pascal" code.'
+#13+ '' +#13+'---------------------------------------------' +#13+#13+
'Gebruik van de functietoetsen:'
+#13+
'EXIT = "F12"'
+#13+
'Nieuw-Nummer = "F8" [of] "Spatiebalk"'
+#13+
'Nieuw-Spel = "F9"'
+#13+
'INFO = "F1"'
+#13+ '' +#13+#13+
'Dit programma mag vrij gebruikt worden voor persoonlijke doeleinde'
+#13+
'THIS PROGRAM IS FREEWARE FOR PRIVATE USE ONLY.'
+#13+ '','INFO - BINGO64CT ', MB_ICONINFORMATION);
end;
procedure TFormMAIN.MenuItemNieuwNummerClick(Sender: TObject);
begin
BtnSPACEBAR.Click;
end;
procedure TFormMAIN.MenuItemNieuwSpelClick(Sender: TObject);
begin
If QuestionDlg ('KEUZE !','De nummers verwijderen van het bord?'+#13+
'',mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
begin
FormCreate(Self);
FormResize(Self);
end;
end;
procedure TFormMAIN.StringGrid1DrawCell(Sender: TObject; ACol, ARow: Integer;
Rect: TRect; State: TGridDrawState);
var size: TSize;
begin
with StringGrid1.Canvas do
begin
StretchDraw(Rect, ImageBG.Picture.Bitmap);
Brush.Style := bsClear;
if plucked[ACol + (ARow*10) +1] then Font.Color := clYellow {clWhite}
else Font.Color := $00A60000; {clBlack}
size := TextExtent(StringGrid1.Cells[ACol,ARow]);
TextOut(Rect.Left + (Rect.Right-Rect.Left-size.cx) div 2,
Rect.Top + 1, StringGrid1.Cells[ACol,ARow]);
end;
end;
procedure TFormMAIN.TimerDATUMTIJDTimer(Sender: TObject);
var
myDate : TDateTime;
begin
mydate:= now;
PanelTijd.Font.Name:= 'Arial';
PanelTijd.Font.Style:= [fsBold];
PanelTijd.Font.Size:= 11;
PanelTijd.Caption := FormatDateTime('DD/MM/yyyy' + ' - ' +'HH:MM', myDate);
//PanelTijd.Caption := DateTimeToStr(Now);
end;
//---------------Timer Functions-----------------//
procedure TFormMAIN.Timer1Timer(Sender: TObject);
var key: char;
begin
key := char(VK_SPACE);
if Order[0] = 90 then Timer1.Enabled := False
else FormKeyPress(Self, key);
end;
procedure TFormMAIN.MenuItemPRINTlandscapeClick(Sender: TObject);
begin
If QuestionDlg ('KEUZE !','Het scherm afdrukken?'+#13+
'',mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
begin
PrintForm(True,poLandscape ); //spec. proc. voor "Form.Print".[poLandscape] [poPortrait]
end;
end;
procedure TFormMAIN.PrintForm(centredOnPage: boolean; anOrientation: TPrinterOrientation);
var
// Belangrijk: In uses 'Types' plaatsen.
VARmyBitMap: TBitMap;
VARprnBmp: TBitmap;
VARprnRct: TRect;
VARHScaleFactor: Single;
VARVScaleFactor: Single;
VARaLeft: Integer;
VARaTop: Integer;
VARaSize: TSize;
begin
VARHScaleFactor:=Printer.XDPI/Screen.PixelsPerInch;
VARVScaleFactor:=Printer.YDPI/Screen.PixelsPerInch;
VARmyBitMap:= TBitMap.Create;
VARprnBmp:=TBitmap.Create;
try
//if not PrintDialog1.Execute then
// Exit;
Printer.Orientation:=anOrientation;
VARmyBitMap.LoadFromDevice(Canvas.Handle);
VARprnBmp.SetSize(trunc(VARmyBitMap.Width*VARHScaleFactor),
trunc(VARmyBitMap.Height*VARVScaleFactor));
VARprnRct:=Rect(0, 0, VARprnBmp.Width, VARprnBmp.Height);
VARprnBmp.Canvas.StretchDraw(VARprnRct, VARmyBitMap);
if centredOnPage then
begin
VARaSize:=Size(Printer.PaperSize.PaperRect.WorkRect);
case Printer.Orientation of
poPortrait: begin
showmessage('P');
VARaLeft:=(VARaSize.cx - VARprnBmp.Width)div 2; // Geen goede output
VARaTop:=(VARaSize.cy - VARprnBmp.Height)div 2; //
end;
poLandscape: begin
VARaTop:=(VARaSize.cy - VARprnBmp.Height)div 10;
VARaLeft:=(VARaSize.cx - VARprnBmp.Width)div 10;
end;
else showmessage(' ! ');
end;
end
else
begin
VARaLeft:=0;
VARaTop:=0;
end;
Printer.BeginDoc;
try
Printer.Canvas.Draw(VARaLeft, VARaTop, VARprnBmp);
finally
Printer.EndDoc;
end;
finally
VARmyBitMap.Free;
VARprnBmp.Free;
end;
end;
function FileExists_wc(AFileSpec: string): Boolean; // _wc staat dan voor wildcard
var
lSearchRec: TSearchRec;
begin
Result := False;
if FindFirst(AFileSpec, faAnyFile, lSearchRec) = 0 then
begin
try
Result := True;
finally
FindClose(lSearchRec);
end;
end;
end;
procedure Deletefiles_wc(AFileSpec: string); // _wc staat dan voor wildcard
var
lSearchRec: TSearchRec;
begin
if FindFirst(AFileSpec, faAnyFile, lSearchRec) = 0 then
begin
try
repeat
DeleteFile(ExtractFilePath(AFileSpec) + lSearchRec.Name);
until SysUtils.FindNext(lSearchRec) <> 0;
finally
FindClose(lSearchRec);
end;
end;
end;
//------Start a new game------//
procedure TFormMAIN.btnImageResetClick(Sender: TObject);
begin
If QuestionDlg ('KEUZE !','De nummers verwijderen van het bord?'+#13+
'',mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
begin
Try
//MenuItemOPSLAANJPG.Click;
finally
FormCreate(Self);
FormResize(Self);
end;
end;
end;
procedure TFormMAIN.MenuItemVERWIJDERENClick(Sender: TObject);
begin
If QuestionDlg ('Opgepast - VERWIJDEREN!','De BINGO-Schermafdrukbestanden ' + #13+#13+
'in BMP formaat'+
#13+#13+ 'verwijderen?'+#13+'',
mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
If FileExists_wc('BINGO*.bmp') then
begin
Deletefiles_wc('BINGO*.bmp');
showmessage('De *.bmp bestanden zijn verwijderd uit deze map ')
end
else
showmessage('GEEN *.bmp bestanden gevonden in deze map');
If QuestionDlg ('Opgepast - VERWIJDEREN !','De BINGO-Schermafdrukbestanden ' + #13+#13+
'in JPG formaat'+
#13+#13+ 'verwijderen?'+#13+'',
mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
If FileExists_wc('BINGO*.jpg') then
begin
Deletefiles_wc('BINGO*.jpg');
showmessage('De *.jpg bestanden zijn verwijderd uit deze map')
end
else
showmessage('GEEN *.jpg bestanden gevonden in deze map ');
end;
//----- SCHERMAFDRUK ------------------------------------------//
procedure TFormMAIN.MenuItemOPSLAANJPGClick(Sender: TObject);
var
varBMPBitMap : TBitMap;
varRct: TRect;
varJpegImage: TJpegImage; // <<<<
varstrDatumTijd : String; // <<<<
begin
varBMPBitMap := TBitMap.Create;
try
varBMPBitMap.LoadFromDevice(Canvas.Handle);
varRct:= Rect(0, 0, trunc(varBMPBitMap.Width),
trunc(varBMPBitMap.Height));
If QuestionDlg ('KEUZE !','Schermafdruk opslaan als JPG?'+#13+
'',mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
begin
varstrDatumTijd := FormatDateTime('yyyy-mm-dd hh.mm.ss', now);
// Dadelijk opslaan in map van de EXE.
varJpegImage := TJpegImage.Create;
varJpegImage.Assign(varBMPBitMap);
varJpegImage.SaveToFile('BINGO '+ varstrDatumTijd +'.jpg');
end;
finally
varBMPBitMap.Free;
varBMPBitMap:=NIL;
varJpegImage.Free;
varJpegImage := NIL;
end;
end;
procedure TFormMAIN.MenuItemOPSLAANBMPClick(Sender: TObject);
var
varBMPBitMap : TBitMap;
vaRrct: TRect;
varstrDatumTijd : String;
begin
varBMPBitMap := TBitMap.Create;
try
varBMPBitMap.LoadFromDevice(Canvas.Handle);
varRct:=Rect(0, 0, trunc(varBMPBitMap.Width),
trunc(varBMPBitMap.Height));
If QuestionDlg ('KEUZE !','Schermafdruk opslaan als BMP?'+#13+
'',mtConfirmation,[mrYes,'JA', mrNo, 'NEEN'],'') = mrYes then
begin
// SAVEN
varstrDatumTijd:= FormatDateTime('yyyy-mm-dd-hh.mm.ss', now);
varBMPBitMap.SaveToFile('BINGO '+ varstrDatumTijd + '.bmp');
end;
finally
varBMPBitMap.Free;
varBMPBitMap:=NIL;
end;
end;
//*************************************************
procedure TFormMAIN.BtnEXITClick(Sender: TObject);
var
varPanExit: TPanel;
varbtnSluit, varbtnBlijf: TSpeedbutton;
begin
if Assigned(varPanExit) then // als panel reeds bestaat alleen maar zichtbaar maken
begin
varPanExit.Visible := true;
exit;
end;
varPanExit := TPanel.Create(Self);
with varPanExit do
begin
Parent := Self;
Color:= clCream;
Top:= StringGrid1.Height div 2;
Left := StringGrid1.Width div 2;
Height:= 150;
Width:= 300;
end;
// varbtnSluit //
varbtnSluit:=TSpeedbutton.Create(nil);
with varbtnSluit do
begin
Parent := varPanExit;
Canvas.TextOut(2, 2, '');
Canvas.TextOut(2, 29, '');
Caption := 'Programma'#10'sluiten !';
Left := 30;
Top := 40;
Width := 110;
Height := 80;
font.Name:= 'arial';
font.Size:= 13;
font.Style:= [fsBold];
font.Color:= clBlack;
varbtnSluit.OnClick := @varbtnSluitClickEvent;
end;
// varbtnBlijf //
varbtnBlijf:=TSpeedbutton.Create(nil);
with varbtnBlijf do
begin
Parent := varPanExit;
Caption := 'Annuleren !';
Left := 160;
Top := 40;
Width := 110;
Height := 80;
font.Name:= 'arial';
font.Size:= 13;
font.Style:= [fsBold];
font.Color:= clBlack;
varbtnBlijf.OnClick := @varbtnBlijfClickEvent;
end;
end;
procedure TFormMAIN.varbtnSluitClickEvent(Sender: TObject);
begin
showmessage('EXIT');
Application.Terminate;
end;
procedure TFormMAIN.varbtnBlijfClickEvent(Sender: TObject);
begin
showmessage('BLIJF');
TSpeedbutton(Sender).Parent.Visible := false;
// TSpeedbutton.Create(Sender).Parent.Visible := false; // dit zet de panel onzichtbaar.
end;
end.
Bookmarks