Page 1 of 2 1 2 LastLast
Results 1 to 15 of 17

Thread: Create Panel + Speedbutton at runtime.

  1. #1
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question Create Panel + Speedbutton at runtime.

    Windows 10 + CodeTyphon 7.1.

    Tracht een Panel met Speedbutton te maken "AT RUNTIME'.

    Weet niet hoe je de ONCLICK van deze button moet realiseren.
    Heb op Google gezocht en volgende code in mekaar gestoken:

    Code:
    uses
      {$IFNDEF WINDOWS} jpeg, {$ENDIF}
      LCLIntf, LCLType, LCLProc,
      SysUtils, Classes, Graphics,
      Controls, Forms, Dialogs, Grids, ExtCtrls,
      Buttons, Menus, Printers, StdCtrls, PrintersDlgs, Types;    
    
    
    type
      { TFormMAIN }
      TFormMAIN = class(TForm)         
    ......
    .........[ hier staan nog andere proc.]
    .............
        procedure MenuItemEXITClick(Sender: TObject); 
        procedure btn1ClickEvent(Sender: TObject);   
    
    
    
    procedure TFormMAIN.MenuItemEXITClick(Sender: TObject);
    var
      Panl: TPanel;
      btn1, btn2: TSpeedbutton;
    begin
      Panl := TPanel.Create(Self);
      with Panl do
      begin
        Parent := StringGrid1;
        Color:= clCream;
        Top:= StringGrid1.Height div 2;
        Left := StringGrid1.Width div 2;
        Height:= 150;
        Width:= 300;
      end;
      btn1:=TSpeedbutton.Create(nil);
      with btn1 do
      begin
        Parent := Panl;
        btn1.Canvas.TextOut(2, 2, '');
        btn1.Canvas.TextOut(2, 29, '');
        btn1.Caption := 'Programma'#10'sluiten !';
        Left := 30;
        Top := 40;
        Width := 110;
        Height := 80;
        font.Name:= 'arial';
        font.Size:= 13;
        font.Style:= [fsBold];
        font.Color:= clBlack;
    // speciale procedure aanroepen
        btn1.OnClick := 
    Het probleem zit in @btn1ClickEvent;
      end;
    end;                   
    
    procedure TFormMAIN.btn1ClickEvent(Sender: TObject);
    begin
      Application.Terminate;
    end;
    Het probleem zit misschien in @btn1ClickEvent?
    Krijg geen ERRORS, maar de procedure werkt niet. Het programma wordt niet gesloten na de click.

  2. #2
    Ik heb de code direct in mijn lazarus gekopiëerd. (Lazarus 2.0.8, W10)
    Ik heb (voor de test, maar niet relevant) de formnaam Form1 gehouden.
    De aanwezigheid van PrintersDlgs gaf een foutmelding - dus verwijderd.
    Code:
        btn1.OnClick := @btn1ClickEvent;
    En daarna: de procedure wordt uitgevoerd en een click op btn1 (die dus @runtime is gemaakt) doet wat die moet doen!
    Er moet dus ergens anders een onverwachte fout zitten...

  3. #3
    Ik weet dat als je Delphi compatibiliteit gebruikt in Lazarus dat je gewoon
    Delphi Code:
    1. btn1.OnClick := btn1ClickEvent;
    kan doen, dan moet je bovenaan in de unit
    Delphi Code:
    1. {$Mode Delphi}
    hebben staan..

  4. #4
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Thumbs up

    De code:
    btn1.OnClick := @btn1ClickEvent;
    werkt inderdaad in een nieuwe applicatie die ik heb aangemaakt.

    Bdankt.

  5. #5
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question

    Ik heb nog een andere probleem!


    In de "procedure TFormMAIN.btn2ClickEvent" zou de Panel (Pan1) moeten verwijderd worden,
    zodat de applicatie gewoon open blijft.


    Code:
    procedure TFormMAIN.BtnEXITClick(Sender: TObject);
      var
        Panl: TPanel;
        btn1, btn2: TSpeedbutton;
      begin
        Panl := TPanel.Create(Self);
        with Panl do
        begin
          Parent := Self; //StringGrid1;
          Color:= clCream;
          Top:= StringGrid1.Height div 2;
          Left := StringGrid1.Width div 2;
          Height:= 150;
          Width:= 300;
        end;
        // BUTTON 1
        btn1:=TSpeedbutton.Create(nil);
        with btn1 do
        begin
          Parent := Panl;
          btn1.Canvas.TextOut(2, 2, '');
          btn1.Canvas.TextOut(2, 29, '');
          btn1.Caption := 'Programma'#10'sluiten !';
          Left := 30;
          Top := 40;
          Width := 110;
          Height := 80;
          font.Name:= 'arial';
          font.Size:= 13;
          font.Style:= [fsBold];
          font.Color:= clBlack;
          btn1.OnClick := @btn1ClickEvent;
        end;
        // BUTTON 2
        btn2:=TSpeedbutton.Create(nil);
        with btn2 do
        begin
          Parent := Panl;
          btn2.Caption := 'Annuleren !';
          Left := 160;
          Top := 40;
          Width := 110;
          Height := 80;
          font.Name:= 'arial';
          font.Size:= 13;
          font.Style:= [fsBold];
          font.Color:= clBlack;
          btn2.OnClick := @btn2ClickEvent;
        end;
    end;
    
    procedure TFormMAIN.btn1ClickEvent(Sender: TObject);
    begin
      showmessage('btn1');
      Application.Terminate;
    end;
    
    procedure TFormMAIN.btn2ClickEvent(Sender: TObject);
    begin
      showmessage('btn2');
     // => Hier moet de Panel gesloten/verwijderd worden !!!!
    end;

  6. #6
    Code:
    TSpeedbutton.Create(Sender).Parent.Visible := false;
    In btn2ClickEvent() maakt je panel onzichtbaar.

    Als je hem echter weer zichtbaar wilt maken moet je eigenlijk pan1 een form variabele maken zodat je hem in BtnEXITClick niet opnieuw aan houdt te maken maar gewoon pan1.Visible := true; kunt doen dus ie al bestaat.

    (Als het je niet lukt kan ik wel completere code maken maar probeer maar even)

    Ps. Ik meen dat het niet verstandig was om vinden een event het component zelf te freeen. En als je pan1.free zou doen wordt er ook een tspeedbutton.free gedaan (wat dus een fout kan geven).

  7. #7
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question

    Bedankt RVK voor jouw reactie.

    Maar ......ik snap het goed en het lukt mij niet.

  8. #8
    .
    Quote Originally Posted by seghele View Post
    Maar ......ik snap het goed en het lukt mij niet.
    Ik bedoelde dit:
    Zet de Pan1 variabele in je Form-declaratie
    Zet de tekst tussen de // --------- in procedure BtnEXITClick();
    Neem de btn2ClickEvent over.

    Delphi Code:
    1. uses
    2.   {$IFNDEF WINDOWS} jpeg, {$ENDIF}
    3.   LCLIntf, LCLType, LCLProc,
    4.   SysUtils, Classes, Graphics,
    5.   Controls, Forms, Dialogs, Grids, ExtCtrls,
    6.   Buttons, Menus, Printers, StdCtrls, PrintersDlgs, Types;    
    7.  
    8.  
    9. type
    10.   { TFormMAIN }
    11.   TFormMAIN = class(TForm)        
    12. ......
    13. .........[ hier staan nog andere proc.]
    14. .............
    15.     Panl: TPanel;
    16.     procedure MenuItemEXITClick(Sender: TObject);
    17.     procedure btn1ClickEvent(Sender: TObject);  
    18.  
    19. procedure TFormMAIN.BtnEXITClick(Sender: TObject);
    20. var
    21.   btn1, btn2: TSpeedbutton;
    22. begin
    23.  
    24.   // ----------------------
    25.   if Assigned(Pan1) then // als panel reeds bestaat alleen maar zichtbaar maken
    26.   begin
    27.     Pan1.Visible := true;
    28.     exit;
    29.   end;
    30.   // ----------------------
    31.  
    32.   Panl := TPanel.Create(Self);
    33.   with Panl do
    34.   begin
    35.     Parent := Self; //StringGrid1;
    36.     Color:= clCream;
    37.     Top:= StringGrid1.Height div 2;
    38.     Left := StringGrid1.Width div 2;
    39.     Height:= 150;
    40.     Width:= 300;
    41.   end;
    42.   // BUTTON 1
    43.   btn1:=TSpeedbutton.Create(nil);
    44.   with btn1 do
    45.   begin
    46.     Parent := Panl;
    47.     btn1.Canvas.TextOut(2, 2, '');
    48.     btn1.Canvas.TextOut(2, 29, '');
    49.     btn1.Caption := 'Programma'#10'sluiten !';
    50.     Left := 30;
    51.     Top := 40;
    52.     Width := 110;
    53.     Height := 80;
    54.     font.Name:= 'arial';
    55.     font.Size:= 13;
    56.     font.Style:= [fsBold];
    57.     font.Color:= clBlack;
    58.     btn1.OnClick := @btn1ClickEvent;
    59.   end;
    60.   // BUTTON 2
    61.   btn2:=TSpeedbutton.Create(nil);
    62.   with btn2 do
    63.   begin
    64.     Parent := Panl;
    65.     btn2.Caption := 'Annuleren !';
    66.     Left := 160;
    67.     Top := 40;
    68.     Width := 110;
    69.     Height := 80;
    70.     font.Name:= 'arial';
    71.     font.Size:= 13;
    72.     font.Style:= [fsBold];
    73.     font.Color:= clBlack;
    74.     btn2.OnClick := @btn2ClickEvent;
    75.   end;
    76. end;
    77.  
    78. procedure TFormMAIN.btn1ClickEvent(Sender: TObject);
    79. begin
    80.   showmessage('btn1');
    81.   Application.Terminate;
    82. end;
    83.  
    84. procedure TFormMAIN.btn2ClickEvent(Sender: TObject);
    85. begin
    86.   TSpeedbutton.Create(Sender).Parent.Visible := false; // dit zet de panel onzichtbaar
    87. end;

    Ik heb wel een klein ander vraagje.
    Waarom doe je het niet zo?

    Delphi Code:
    1. procedure TForm1.btnExitClick(Sender: TObject);
    2. begin
    3.   Close;
    4. end;
    5.  
    6. procedure TForm1.FormCloseQuery(Sender: TObject; var CanClose: boolean);
    7. begin
    8.   case QuestionDlg('Beeindigen', 'Programma sluiten ?', mtCustom,
    9.       [mrYes, 'Ja, doe maar', mrNo, 'Nee', 'IsDefault'], '') of
    10.     mrYes: CanClose := True;
    11.     mrNo: CanClose := False;
    12.   end;
    13. end;

    De btnExit doet gewoon een Close. Maar omdat er een FormCloseQuery is wordt die altijd eerst uitgevoerd. Voordeel daarvan is dat ook de Alt+F4 (beeindig programma) en het rode kruisje bovenin afgevangen worden door je dialoog. En de QuestionDlg() is een makkelijkere manier dan een panel. En je hebt veel minder code

  9. #9
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Exclamation

    Bedankt rvk

    Bij Windows 8.1 had ik "QuestionDlg" gebruikt, maar nu in Windows 10 ontstaat er een probleem.
    Namelijk de tekst op de buttons is niet meer zichtbaar, maar ze werken wel.
    Daarom tracht ik via een omweg (met meer code) volwaardige buttons te laten zien.
    Voor andere dialogs (zelfs met showmessage) is de tekst (OK) op de button ook onzichtbaar, maar wel werkende opdracht.

    Jouw code zal ik asap inwerken in het programma en het resultaat mededelen.

  10. #10
    Quote Originally Posted by seghele View Post
    Bij Windows 8.1 had ik "QuestionDlg" gebruikt, maar nu in Windows 10 ontstaat er een probleem.
    Namelijk de tekst op de buttons is niet meer zichtbaar, maar ze werken wel.
    Daarom tracht ik via een omweg (met meer code) volwaardige buttons te laten zien.
    Voor andere dialogs (zelfs met showmessage) is de tekst (OK) op de button ook onzichtbaar, maar wel werkende opdracht.
    Oei... dat is dus eigenlijk een heel ander probleem.
    Dan werken er denk ik een heleboel dingen niet (o.a. met standaard dialogen).
    Is dat een bekend iets bij CodeTyphon?

    Normaal zou ik dan eerder zoeken naar een oplossing voor dat probleem, dan het probleem op deze manier te omzeilen.

    Edit: Even CodeTyphon uitgetest maar ik krijg de buttons wel gewoon te zien (Windows 10 / CodeTyphon 7.10)
    Dus er zal iets mis zijn met je installatie.
    Last edited by rvk; 14-May-20 at 16:32.

  11. #11
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question

    Ik krijg error !

    Compile Project, Target: Bingo64CT.exe: Exit code 1, Errors: 8, Hints: 3
    Bingo1.pas(454,5) Note: Local variable "varRct" is assigned but never used
    Bingo1.pas(483,5) Note: Local variable "vaRrct" is assigned but never used
    Bingo1.pas(510,17) Error: Identifier not found "Pan1"
    Bingo1.pas(512,9) Error: Identifier not found "Pan1"
    Bingo1.pas(516,5) Error: Identifier not found "Panl"
    Bingo1.pas(517,10) Error: Identifier not found "Panl"
    Bingo1.pas(517,15) Error: Expression type must be class or record type, got <erroneous type>
    Bingo1.pas(530,17) Error: Identifier not found "Panl"
    Bingo1.pas(548,17) Error: Identifier not found "Panl"
    Bingo1.pas(571,29) Error: Incompatible type for arg no. 1: Got "TObject", expected "TComponent"
    speedbutton.inc(35,32) Hint: Found declaration: constructor Create(TComponent);

    Code:
    procedure TFormMAIN.BtnEXITClick(Sender: TObject);
      var
        //Panl: TPanel;
        btn1, btn2: TSpeedbutton;
      begin
        // ----------------------
        if Assigned(Pan1) then // als panel reeds bestaat alleen maar zichtbaar maken
        begin
            Pan1.Visible := true;
            exit;
        end;
        // ----------------------
        Panl := TPanel.Create(Self);
        with Panl do
        begin
          Parent := Self; //StringGrid1;
          Color:= clCream;
          Top:= StringGrid1.Height div 2;
          Left := StringGrid1.Width div 2;
          Height:= 150;
          Width:= 300;
        end;
        // BUTTON 1
        btn1:=TSpeedbutton.Create(nil);
        with btn1 do
        begin
          Parent := Panl;
          btn1.Canvas.TextOut(2, 2, '');
          btn1.Canvas.TextOut(2, 29, '');
          btn1.Caption := 'Programma'#10'sluiten !';
          Left := 30;
          Top := 40;
          Width := 110;
          Height := 80;
          font.Name:= 'arial';
          font.Size:= 13;
          font.Style:= [fsBold];
          font.Color:= clBlack;
          btn1.OnClick := @btn1ClickEvent;
        end;
        // BUTTON 2
        btn2:=TSpeedbutton.Create(nil);
        with btn2 do
        begin
          Parent := Panl;
          btn2.Caption := 'Annuleren !';
          Left := 160;
          Top := 40;
          Width := 110;
          Height := 80;
          font.Name:= 'arial';
          font.Size:= 13;
          font.Style:= [fsBold];
          font.Color:= clBlack;
          btn2.OnClick := @btn2ClickEvent;
        end;
    end;
    
    procedure TFormMAIN.btn1ClickEvent(Sender: TObject);
    begin
      showmessage('btn1');
      Application.Terminate;
    end;
    
    procedure TFormMAIN.btn2ClickEvent(Sender: TObject);
    begin
      showmessage('btn2');
      TSpeedbutton.Create(Sender).Parent.Visible := false; // dit zet de panel onzichtbaar.
    end;
    Aangaande Windows 10 .... ik zou niet weten waar en hoe ik dit Microsoft installatie probleem moet oplossen.
    Persoonlijk gebruik ik veel meer Linux-Mint. Via "Wine" kan ik alle 'exe' programma's uitvoeren.
    Dus ... indien het enkel om dit klein onzichtbaar 'button' probleem, dat zet ik liever wat meer code in mijn CodeTyphon programma.

  12. #12
    Heb je die pan1 ook in je formdeclaratie gezet zoals ik zei en liet zien?


    Quote Originally Posted by seghele View Post
    Ik krijg error !

    Bingo1.pas(516,5) Error: Identifier not found "Panl"
    Bingo1.pas(517,10) Error: Identifier not found "Panl"
    Sorry. Ik zag niet dat het PanL was (met een L).
    Ik dacht dat het een 1 was.
    Verander in al mijn wijzingen dus de pan1 in panl.

    Maar vergeet hem dus niet bovenin te declareren.

  13. #13
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question

    Heb de code iets duidelijker gemaakt om probleem van "1" en "l" op te lossen.

    Maar er blijft een ERROR in: "TSpeedbutton.Create(Sender).Parent.Visible := false; "

    Bingo1.pas(572,29) Error: Incompatible type for arg no. 1: Got "TObject", expected "TComponent"
    Code:
    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 := @btn1ClickEvent;
        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 := @btn2ClickEvent;
        end;
    end;
    
    procedure TFormMAIN.btn1ClickEvent(Sender: TObject);
    begin
        showmessage('SLUITEN');
      Application.Terminate;
    end;
    
    procedure TFormMAIN.btn2ClickEvent(Sender: TObject);
    begin
        showmessage('BLIJF');
      TSpeedbutton.Create(Sender).Parent.Visible := false; // dit zet de panel onzichtbaar.
    end;
    Reeds dank bij voorbaat.

  14. #14
    Wederom tikfoutje van mij (dat krijg je als je op een mobieltje knipt en plakt)..

    Het moet zijn
    Delphi Code:
    1. TSpeedbutton(Sender).Parent.Visible := false;

    De TSpeedbutton(Sender) is een 'cast' naar de aanroeper van de functie (de button).
    Vervolgens pak je met .parent het component waar de button op staat (het panel).
    En die zet je met .visible := false op onzichtbaar.

    (Die .Create hoort er dus niet tussen)

  15. #15
    Senior Member
    Join Date
    Sep 2004
    Location
    BELGIE(Vilvoorde)
    Posts
    685

    Question

    Het noodlot blijft mij achtervolgen !!!!

    Krijg GEEN error bij het compileren.
    Maar het programma start wel op en bijna alle functies werken, behalve de Exit button(BtnEXITClick).
    Berichten, Errors: 1
    Error: Project Bingo64CT raised exception class 'External: SIGSEGV'.

    At address 10002C737
    Ik laat je de volledige "pas":
    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.

Page 1 of 2 1 2 LastLast

Thread Information

Users Browsing this Thread

There are currently 1 users browsing this thread. (0 members and 1 guests)

Bookmarks

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •