Johnny Smash

January 4, 2023

Well, Stano, grdselection1 and grdselection2 were both a TwwDBGrid (Woll2Woll). Now they are of TDBGrid.

January 4, 2023

Clear Lars. But this is not my doing. It is the coding of somebody else. It is part of a program.

I am trying to change all the InfoPower components from Woll2Woll back to standard Delphi ones.

Delphi sees 'Selected, Clear, Add and ApplySelected' each as a "undeclared identifier" and halts.

What could be the cause of this error you think, please?

January 4, 2023

Welcome back. Now I have a piece of source code, which is bothering me. Compiling is hold on this part:

with grdSelection1 do
    begin
      Selected.Clear;
      Selected.Add('BackNr' + #9 + '3'+ #9 + 'Nr');
      Selected.Add('FullName' + #9 + '20'+ #9 + 'Player');
      Selected.Add('MinutesInMatch' + #9 + '3'+ #9 + 'Min');
      ApplySelected;
    end;

Delphi sees 'Selected, Clear, Add and ApplySelected' each as a "undeclared identifier". So what is going wrong?

Is an external component missing? Do I need to declare a variable? Does anybody have an idea, please?

January 21, 2021

Quote

Please try to use the English language. And please post longer code-segments as file-attachments.

Ja, Lars. Daniel advarede mig allerede (see qote). Men jeg venter på, at emailx45 skal svare mig.

Han arbejder på et problem. Snart slutter dette indlæg alligevel.

January 20, 2021

unit sqlconst;

interface

uses
  classes, SysUtils;

const
  SQL_MATCH_COUNT = 29;
  SQL_MATCH : array[0..SQL_MATCH_COUNT -1] of string =
    ('SELECT Match.SeasonId, Match.RoundNr, Match.GroupNr, Match.MatchNr, Match.MatchId,',
     '   Match.Return, Match.Team1Id, Match.Team2Id, Match.Winner, Match.MatchDateTime,',
     '   Match.InTabelle, Match.StadiumId, Match.RefereeId, Match.Text, Match.Visitors, Match.Coach1Id,',
     '   Match.Coach2Id, Match.SpToreStr1, Match.SpToreStr2, Match.SpPunkte1, Match.SpPunkte2,',
     '   Match.SpPunkte3, Match.SpPunkte4, Match.SpBilanz1, Match.SpBilanz2, Match.SpTore1,',
     '   Match.SpTore2, Match.SpTore3, Match.SpTore4, Match.StaWertung, Match.SchiriKosten,',
     '   Match.SelectFeld, Team1.TeamId tm1TeamId, Team1.TeamName tm1TeamName, Team1.Country tm1Country,',
     '   Team2.TeamId tm2TeamId, Team2.TeamName tm2TeamName, Team2.Country tm2Country,',
     '   Coach1.CoachId co1CoachId, Coach1.FullName co1FullName, Coach1.Nationality co1Nationality,',
     '   Coach2.CoachId co2CoachId, Coach2.FullName co2FullName, Coach2.Nationality co2Nationality,',
     '   Referee.RefereeId refRefereeId, Referee.FullName refFullName, Referee.Nationality, Stadium.StadiumId staStadiumId,',
     '   Stadium.FullName staFullName, Stadium.Capacity staCapacity, Stadium.Country staCountry',
     'FROM "PREFIX15.DB" Match',
     '   LEFT OUTER JOIN "PREFIX01.DB" Team1',
     '   ON  (Match.Team1Id = Team1.TeamId)',
     '   LEFT OUTER JOIN "PREFIX01.DB" Team2',
     '   ON  (Match.Team2Id = Team2.TeamId)',
     '   LEFT OUTER JOIN "PREFIX03.DB" Coach1',
     '   ON  (Match.Coach1Id = Coach1.CoachId)',
     '   LEFT OUTER JOIN "PREFIX03.DB" Coach2',
     '   ON  (Match.Coach2Id = Coach2.CoachId)',
     '   LEFT OUTER JOIN "PREFIX04.DB" Referee',
     '   ON  (Match.RefereeId = Referee.RefereeId)',
     '   LEFT OUTER JOIN "PREFIX05.DB" Stadium',
     '   ON  (Match.StadiumId = Stadium.StadiumId)',
     'WHERE   (Match.SeasonId = :prmSeasonId)',
     '   AND  (Match.RoundNr = :prmRoundNr)',
     '   AND  (Match.GroupNr = :prmGroupNr)',
     '   AND  (Match.MatchNr = :prmMatchNr)');

  SQL_MATCH_SELECTION_COUNT = 5;
  SQL_MATCH_SELECTION : array[0..SQL_MATCH_SELECTION_COUNT -1] of string =
    ('select *',
     'from "PREFIX16.db" pim, "PREFIX02.db" pla',
     'where (pim.PlayerId = pla.PlayerId)',
     '   and (MatchId = :prmMatchId)',
     'order by PlaysForTeam, BackNr');

  SQL_MATCH_EVENTS_COUNT = 6;
  SQL_MATCH_EVENTS : array[0..SQL_MATCH_EVENTS_COUNT -1] of string =
    ('SELECT Goal.MatchId, Goal.PlayerId, Goal.GoalMinute, Goal.GoalForTeam, Goal.OwnGoal, Goal.Comment, Player.FullName',
     'FROM "PREFIX17.DB" Goal',
     '   LEFT OUTER JOIN "PREFIX02.DB" Player',
     '   ON  (Goal.PlayerId = Player.PlayerId)',
     'WHERE  (Goal.MatchId = :prmMatchId)',
     'ORDER BY Goal.GoalMinute');


procedure UpdateSqlPrefixes(SQL: TStrings; Prefix: string);

implementation

procedure UpdateSqlPrefixes(SQL: TStrings; Prefix: string);
var
  Regel: integer;
  p:     integer;
begin
  for Regel := 0 to SQL.Count - 1 do
  begin
    p := Pos('PREFIX', SQL[Regel]);
    while (p > 0) do
    begin
      SQL[Regel] := Copy(SQL[Regel], 1, p-1) + Prefix + Copy(SQL[Regel], p + 6, Length(SQL[Regel]) - p - 5);
      p := Pos('PREFIX', SQL[Regel]);
    end;
  end;
end; // UpdateSqlPrefixes

end.

January 20, 2021

unit dstat;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  Db, DBTables, Wwquery;

type
  TdtmStat = class(TDataModule)
    qryMatch: TwwQuery;
    qryMatchSelection: TwwQuery;
    qryMatchEvents: TwwQuery;
    procedure dtmStatDestroy(Sender: TObject);
  private
    FDatabase: TDatabase;
  public
    procedure SetDatabaseToUse(aDatabase: TDatabase);
    procedure UpdateQueries(aPrefix: string);
    procedure CloseQueries;
  end;

var
  dtmStat: TdtmStat;

implementation

{$R *.DFM}

uses
  sqlconst;

//__________________________________________________________________________________________
procedure TdtmStat.SetDatabaseToUse(aDatabase: TDatabase);
begin
  FDatabase := aDatabase;
  qryMatch.DatabaseName := FDatabase.DatabaseName;
  qryMatchSelection.DatabaseName := FDatabase.DatabaseName;
  qryMatchEvents.DatabaseName := FDatabase.DatabaseName;
end; // SetDatabaseToUse

//__________________________________________________________________________________________
procedure TdtmStat.UpdateQueries(aPrefix: string);
begin
  UpdateSqlPrefixes(qryMatch.SQL, aPrefix);
  UpdateSqlPrefixes(qryMatchSelection.SQL, aPrefix);
  UpdateSqlPrefixes(qryMatchEvents.SQL, aPrefix);
  // en bereid de queries voor
  qryMatch.Prepare;
  qryMatchSelection.Prepare;
  qryMatchEvents.Prepare;
end; // UpdateQueries

//__________________________________________________________________________________________
procedure TdtmStat.dtmStatDestroy(Sender: TObject);
begin
  // unprepare de queries
  if qryMatch.Prepared then
    qryMatch.UnPrepare;
  if qryMatchSelection.Prepared then
    qryMatchSelection.UnPrepare;
  if qryMatchEvents.Prepared then
    qryMatchEvents.UnPrepare;
  // en sluit ze
  qryMatch.Close;
  qryMatchSelection.Close;
  qryMatchEvents.Close;
end; // dtmStatDestroy

//__________________________________________________________________________________________
procedure TdtmStat.CloseQueries;
begin
  qryMatch.Close;
  qryMatchSelection.Close;
  qryMatchEvents.Close;
  // unprepare de queries
  if qryMatch.Prepared then
    qryMatch.UnPrepare;
  if qryMatchSelection.Prepared then
    qryMatchSelection.UnPrepare;
  if qryMatchEvents.Prepared then
    qryMatchEvents.UnPrepare;
end; // CloseQueries

end.

January 20, 2021

unit fNewKeyInteger;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls;

type
  TfrmNewKeyInteger = class(TForm)
    pnlData: TPanel;
    pnlCommands: TPanel;
    pnlSluiten: TPanel;
    cmdOk: TButton;
    cmdAnnuleer: TButton;
    lblKeyName: TLabel;
    txtNieuweKey: TEdit;
    procedure FormActivate(Sender: TObject);
    procedure cmdOkClick(Sender: TObject);
  private
    { Private declarations }
    function GetNieuweKey: integer;
    procedure SetNieuweKey(aValue: integer);
    procedure SetKeyName(aValue: string);
  public
    { Public declarations }
    property NieuweKey: integer read GetNieuweKey write SetNieuweKey;
    property KeyName: string write SetKeyName;
  end;

implementation

{$R *.DFM}

uses
  fmConsts;

procedure TfrmNewKeyInteger.FormActivate(Sender: TObject);
begin
  txtNieuweKey.SetFocus;
  txtNieuweKey.Text := '';
end;

function TfrmNewKeyInteger.GetNieuweKey: integer;
begin
  Result := StrToIntDef(txtNieuweKey.Text, 0);
end;

procedure TfrmNewKeyInteger.SetNieuweKey(aValue: integer);
begin
  txtNieuweKey.Text := IntToStr(aValue);
end;

procedure TfrmNewKeyInteger.SetKeyName(aValue: string);
begin
  lblKeyName.Caption := aValue;
end;

procedure TfrmNewKeyInteger.cmdOkClick(Sender: TObject);
begin
  if txtNieuweKey.Text <> '' then
    begin
      if (StrToIntDef(txtNieuweKey.Text, 0) > 0) then
        ModalResult := mrOk
      else
        begin
          MessageDlg('Please enter a positive number', mtError, [mbOk], 0);
          txtNieuweKey.SetFocus;
        end;
    end
  else
  begin
    Messagedlg(Format(VALUE_REQUIRED, [lblKeyName.Caption]), mtError, [mbOk], 0);
    txtNieuweKey.SetFocus;
  end;
end;

end.

January 20, 2021

unit fmconsts;

interface

uses
  forms, classes, SysUtils;

const
  // do we use the debug log?
  USE_DEBUG_LOG = True;
  USE_DEBUG_LOG_FILE = False;

  // database messages
  CONFIRM_DELETE_DATA = 'The data is about to be deleted. Are you sure?';
  CONFIRM_APPLY_CHANGES = 'The data has changed. Save changes?';
  DELETE_OBJECT_REFERENCED = 'There are references to this object. It can''t be deleted.';
  VALUE_REQUIRED = 'Please enter a value for field ''%s''.';

  // constants for data objects
  SEASON_TABLE_NAME  = 'TESTER07.DB';
  SEASON_KEY_FIELD   = 'SeasonId';
  SEASON_NAME_FIELD  = 'SeasonName';
  SEASON_NEW_CAPTION = 'New season';
  SEASON_NEW_KEYNAME = 'Season no.';

  MATCH_TABLE_NAME  = 'TESTER15.DB';
  MATCH_KEY_FIELD   = 'MatchNr';
  MATCH_NAME_FIELD  = 'MatchId';
  MATCH_NEW_CAPTION = 'New match';
  MATCH_NEW_KEYNAME = 'Match no.';

  // pages on basic data form
  PAGE_TOPIC: array[0..8] of string =
   ('competition', 'team', 'player', 'coach', 'referee', 'stadium', 'country',
    'position', 'system');
  // positions on the field
  FIELD_POSITION: array[0..22] of string =
   ('Unknown', 'Defense', 'Goalkeeper', 'Sweeper', 'Left back', 'Left centre back',
    'Centre back', 'Right centre back', 'Right back', 'Midfield', 'Defensive midfield',
    'Left half', 'Centre half', 'Right half', 'Forward midfield', 'Forward',
    'Inside left', 'Inside right', 'Outside left', 'Left centre forward', 'Centre forward',
    'Right centre forward',  'Outside right');
  // known systems
  FIELD_SYSTEMS: array[0..23,0..5] of string =
   (('Year', 'K', 'D', 'M', 'F', 'Name'),
    ('1920', '1', '2', '3', '5', 'MM/ACH'),
    ('1930', '1', '3', '2', '5', 'WM/DCH'),
    ('1935', '1', '3', '3', '4', 'Verrou'),
    ('1941', '1', '3', '4', '3', 'Diagonal'),
    ('1984', '1', '3', '5', '2', 'sweeper/diamond/flat'),
    ('1950', '1', '4', '2', '4', 'sweeper/flat/flat'),
    ('1952', '1', '4', '2', '4', 'flat/flat/flat'),
    ('1942', '1', '4', '3', '3', 'Muralha'),
    ('1962', '1', '4', '3', '3', 'flat/flat/flat'),
    ('',     '1', '4', '3', '3', 'flat/dm/flat'),
    ('',     '1', '4', '3', '3', 'flat/fm/flat'),
    ('1974', '1', '4', '3', '3', 'sweeper/flat/flat'),
    ('',     '1', '4', '3', '3', 'sweeper/dm/flat'),
    ('',     '1', '4', '3', '3', 'sweeper/fm/flat'),
    ('1982', '1', '4', '4', '2', 'flat/diamond/flat'),
    ('1986', '1', '4', '4', '2', 'sweeper/diamond/flat'),
    ('',     '1', '4', '5', '1', 'flat/diamond/flat'),
    ('',     '1', '4', '5', '1', 'sweeper/diamond/flat'),
    ('1960', '1', '5', '2', '3', 'sweeper/flat/flat'),
    ('',     '1', '5', '3', '2', 'sweeper/flat/flat'),
    ('1984', '1', '5', '3', '2', 'sweeper/dm/flat'),
    ('',     '1', '5', '3', '2', 'sweeper/fm/flat'),
    ('',     '1', '5', '4', '1', 'sweeper/diamond/flat'));
  // descriptions of rounds
  ROUND_DESCR_001 = 'Not fixed';
  ROUND_DESCR_002 = 'Group round';
  ROUND_DESCR_014 = '1/64 finals';
  ROUND_DESCR_015 = '1/32 finals';
  ROUND_DESCR_016 = '1/16 finals';
  ROUND_DESCR_017 = '1/8 finals';
  ROUND_DESCR_018 = 'Quarter-finals';
  ROUND_DESCR_019 = 'Semi-finals';
  ROUND_DESCR_020 = 'Final';
  ROUND_DESCR_103 = 'Play for 3rd place';
  ROUND_DESCR_105 = 'Play for 5rd place';
  ROUND_DESCR_107 = 'Play for 7rd place';
  ROUND_DESCR_109 = 'Play for 9rd place';
  ROUND_DESCR_111 = 'Play for 11rd place';
  ROUND_DESCR_113 = 'Play for 13rd place';
  ROUND_DESCR_115 = 'Play for 15rd place';
  ROUND_DESCR_117 = 'Play for 17rd place';
  // error codes
  ERROR_NO_ERROR      =  0;
  ERROR_INITIALIZE    = -1;
  ERROR_EXECUTE       = -2;
  ERROR_FINALIZE      = -3;
  ERROR_OPEN_DATABASE = -4;
  ERROR_NO_RECORD     = -5;

type
  EFmException = class(Exception);

  EFmDatabaseException = class(EFmException);

  EFmDbInsufficientParameters = class(EFmDatabaseException);

  EFmDbIntegrityViolation = class(EFmDatabaseException);

  EFmDbFieldException = class(EFmDatabaseException)
  private
    FFieldName: string;
  public
    constructor Create(const Msg, aFieldName: String); {override;}
    property FieldName: string read FFieldName write FFieldName;
  end;

  EFmDbFieldRequired = class(EFmDbFieldException);

  // query sort procedure types
  TfgSortType = (stByName, stByCountry, stDontCare);
  TfgNational = (inDontCare, inYes, inNo);
  TSortProcedure = procedure (SortType: TfgSortType; IsNational: TfgNational) of object;
  // types for basic data pagecontrol
  TPageNumber = Byte;
  TExternalPages = set of TPageNumber;
  TIdForm = (ifCompetition, ifTeam, ifPlayer, ifCoach, ifReferee, ifStadium, ifCountry);
  TfvgFormState = (fsUnknown, fsBrowsing, fsEditing, fsInserting);
  TOwnEditForm = class(TForm)
  private
    FCurrentRecordId: integer;
    FFormState: TfvgFormState;
    constructor Create(AOwner: TComponent); override;
    procedure SetFormstate(Value: TfvgFormState);
  public
    procedure InitializeForm; dynamic;
    procedure UpdateFormState; dynamic;
    property FormState: TfvgFormState read FFormState write SetFormstate;
    property CurrentRecordId: integer read FCurrentRecordId write FCurrentRecordId; // key of current season
  end;

implementation

//__________________________________________________________________________________________
constructor EFmDbFieldException.Create(const Msg, aFieldName: String);
begin
  {inherited Create(Msg);}
  Message := Msg;

  FFieldName := aFieldName;
end;

//__________________________________________________________________________________________
constructor TOwnEditForm.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  //FCurrentRecordId := -1;
  //FFormState := fsBrowsing;
end; // Create

//__________________________________________________________________________________________
procedure TOwnEditForm.SetFormstate(Value: TfvgFormState);
begin
  if Value <> FFormState then
  begin
    FFormState := Value;
    UpdateFormState;
  end;
end; // SetFormstate

//__________________________________________________________________________________________
procedure TOwnEditForm.InitializeForm;
begin
  //
end; // InitializeForm

//__________________________________________________________________________________________
procedure TOwnEditForm.UpdateFormState;
begin
  //
end; // UpdateFormState

end.

January 18, 2021

unit fDebugLog;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, 
  Forms, Dialogs, StdCtrls;

type
  TfrmDebugLog = class(TForm)
    mmoDebugLog : TMemo;
    procedure FormCreate(Sender: TObject);
    procedure FormDestroy(Sender: TObject);
  private
    { Private declarations }
    FDebugLogFile : TextFile;
  public
    { Public declarations }
    procedure WriteToDebugLog(Msg: string);
  end;

var
  frmDebugLog : TfrmDebugLog;

implementation

{$R *.DFM}

uses
  fmConsts;

procedure TfrmDebugLog.FormCreate(Sender: TObject);
begin
  Left := 0;
  Top  := 0;
  if USE_DEBUG_LOG_FILE then
    begin
      AssignFile(FDebugLogFile, ExtractfilePath(Application.ExeName) + 'Debuglog ' + FormatDateTime('dd-mm-yyyy hhnn', Now) + '.txt');
      Rewrite(FDebugLogFile);
    end;
end;

procedure TfrmDebugLog.WriteToDebugLog(Msg: string);
begin
  with mmoDebugLog do
    begin
      Lines.Add(TimeToStr(Time) + ': ' + Msg);
      if USE_DEBUG_LOG_FILE then
        WriteLn(FDebugLogFile, TimeToStr(Time) + ': ' + Msg);
      SelectAll;
      Selstart := SelLength;
    end;
end;

procedure TfrmDebugLog.FormDestroy(Sender: TObject);
begin
  if USE_DEBUG_LOG_FILE then
    CloseFile(FDebugLogFile);
end;

end.

January 18, 2021

unit fdbinfothread;

interface

uses
  Forms, Classes, DBTables, SysUtils, fmdmbasic;

type
  TDBInfoStructure = record
    NrOfCompetitions: integer;
    NrOfTeams: integer;
    NrOfPlayers: integer;
    NrOfCoaches: integer;
    NrOfReferees: integer;
    NrOfStadiums: integer;
    NrOfCountries: integer;
    NrOfSeasons: integer;
    NrOfMatches: integer;
  end;
  TDBInfo = ^TDBInfoStructure;

  TDBInfoThread = class(TThread)
  private
    FSession: TSession;
    FQuery: TQuery;
    FPrefix: string;
    FOwner: TForm;
    FDBInfoStructure: TDBInfoStructure;
    FDBInfo: TDBInfo;
  protected
    procedure Execute; override;
    procedure UpdateDatabaseInfo;
  published
    constructor Create(aOwner: TForm; DBName, aPrefix: string; aDBInfo: TDBInfo; aQuery: TQuery);
    destructor Destroy; override;
  end;

implementation

constructor TDBInfoThread.Create(aOwner: TForm; DBName, aPrefix: string; aDBInfo: TDBInfo; aQuery: TQuery);
begin
  inherited Create(false);
  FOwner := aOwner;
  FPrefix := aPrefix;
  FDBInfo := aDBInfo;
  {FSession := TSession.Create(nil);
  FSession.SessionName := IntToStr(ThreadId);
  FSession.OpenDatabase(DBName);
  FQuery := TQuery.Create(nil);
  FQuery.SessionName := FSession.SessionName; }
  FQuery := aQuery;
  with FDBInfoStructure do
  begin
    NrOfCompetitions := 0;
    NrOfTeams := 0;
    NrOfPlayers := 0;
    NrOfCoaches := 0;
    NrOfReferees := 0;
    NrOfStadiums := 0;
    NrOfCountries := 0;
    NrOfSeasons := 0;
    NrOfMatches := 0;
  end;
  FreeOnTerminate := true;
end;

destructor TDBInfoThread.Destroy;
begin
  FSession.Free;
  FQuery.Free;
end;

procedure TDBInfoThread.Execute;
begin
  with FQuery, FDBInfoStructure do
  begin
    Close;
    SQL.Clear;
    SQL.Add('select count(*) nr from');
    SQL.Add(FPrefix+'00.db');
    Open;
    NrOfCompetitions := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'01.db';
    Open;
    NrOfTeams := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'02.db';
    Open;
    NrOfPlayers := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'03.db';
    Open;
    NrOfCoaches := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'04.db';
    Open;
    NrOfReferees := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'05.db';
    Open;
    NrOfStadiums := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'06.db';
    Open;
    NrOfCountries := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'07.db';
    Open;
    NrOfSeasons := FieldByName('nr').AsInteger;
    Close;
    SQL[1] := FPrefix+'15.db';
    Open;
    NrOfMatches := FieldByName('nr').AsInteger;
    Close;
  end;
  Synchronize(UpdateDatabaseInfo);
end;

procedure TDBInfoThread.UpdateDatabaseInfo;
begin
  FDBInfo^ := FDBInfoStructure;
end;

end.

January 18, 2021

unit fBaseDataObjectInteger;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  fBaseDataObject, Db, Wwdatsrc, DBTables, Wwquery;

type
  TdoBaseDataObjectInteger = class(TdoBaseDataObject)
  private
    { Private declarations }
  protected
    FObjectKey: LongInt;
    { Protected declarations }
  	procedure GenerateKey; override;

  	function ObtainKey: boolean; override;

    function CreateRecord: boolean; override;

    function KeyExists : Boolean; override;

  public
    { Public declarations }
    constructor Create( AOwner : TComponent;
      aTableName, aKeyField, aNameField, aNewCaption, aNewKeyName: string ); override;

    procedure SelectObject; override;
    function LocateObject(aKeyValues: array of const): Boolean; override;

    property NewKey: LongInt read FObjectKey;
  end;

//var
//  doBaseDataObjectInteger : TdoBaseDataObjectInteger;

implementation

uses
  fmmain, // ***** for debugging
  fNewKeyInteger,
  fmconsts;

{$R *.DFM}

//__________________________________________________________________________________________
constructor TdoBaseDataObjectInteger.Create( AOwner : TComponent;
  aTableName, aKeyField, aNameField, aNewCaption, aNewKeyName: string );
begin
  frmMain.DebugLog('   --> TdoBaseDataObjectInteger.Create');
  inherited Create( AOwner, aTableName, aKeyField, aNameField, aNewCaption, aNewKeyName );

  FTableName    := aTableName;
  FKeyField     := aKeyField;
  FNameField    := aNameField;

  FNewCaption := aNewCaption;
  FNewKeyName := aNewKeyName;

  with qryObject do
    begin
      SQL.Clear;
      SQL.Add( 'SELECT * FROM' );
      SQL.Add( FTableName);
      SQL.Add( 'WHERE ' + FKeyField + ' = :prm' + FKeyField );

      ParamByName( 'prm' + FKeyField ).DataType := ftInteger;
      Prepare;
    end;

  with qryLijst do
    begin
      SQL.Clear;
      SQL.Add( 'SELECT * FROM' );
      SQL.Add( FTableName );
      SQL.Add( 'ORDER BY ' + FNameField );
      Prepare;
    end;

  with qryInsert do
    begin
      SQL.Clear;
      SQL.Add( 'INSERT INTO' );
      SQL.Add( FTableName );
      SQL.Add( '  (' + FKeyField + ')' );
      SQL.Add( 'VALUES' );
      SQL.Add( '  (:prm' + FKeyField + ')' );

      ParamByName( 'prm' + FKeyField ).DataType := ftInteger;
      Prepare;
    end;

  with qryCheckKey do
    begin
      SQL.Clear;
      SQL.Add( 'SELECT * FROM' );
      SQL.Add( FTableName );
      SQL.Add( 'WHERE ' + FKeyField + ' = :prm' + FKeyField );

      ParamByName( 'prm' + FKeyField ).DataType := ftInteger;
      Prepare;
    end;

  with qryGetLastKey do
    begin
      SQL.Clear;
      SQL.Add( 'SELECT * FROM' );
      SQL.Add( FTableName );
      SQL.Add( 'ORDER BY ' + FKeyField + ' DESC' );
      Prepare;
    end;
  frmMain.DebugLog('   <-- TdoBaseDataObjectInteger.Create');
end;

//__________________________________________________________________________________________
procedure TdoBaseDataObjectInteger.SelectObject;
begin
  frmMain.DebugLog('  --> doIntegerObject SelectObject');
  with qryObject do
    begin
      Close;
      ParamByName( 'prm' + FKeyField ).asInteger := qryLijst.FieldByName(FKeyField).AsInteger;
      Open;
    end;
  frmMain.DebugLog('  <-- doIntegerObject SelectObject');
end;

{______________________________________________________________________________}
procedure TdoBaseDataObjectInteger.GenerateKey;
begin
  frmMain.DebugLog('    --> doIntegerObject GenerateKey');

  with qryGetLastKey do
    begin
      Close;
      Open;
      FObjectKey := FieldByName(FKeyField).AsInteger + 1;
      Close;
    end;

  frmMain.DebugLog('      Key generated = ' + IntToStr(FObjectKey));
  frmMain.DebugLog('    <-- doIntegerObject GenerateKey');
end;

//__________________________________________________________________________________________
function TdoBaseDataObjectInteger.ObtainKey: boolean;
var
  lForm : TfrmNewKeyInteger;
  lbAskIdAgain: boolean;
begin
  frmMain.DebugLog('    --> doIntegerObject ObtainKey');
  { er is nog geen key gegeven }
  Result := False;

  lForm := TfrmNewKeyInteger.Create(Application);
  try
    lForm.Caption := FNewCaption;
    lForm.KeyName := FNewKeyName;
    lbAskIdAgain := False;
    repeat
      FObjectKey := 0;
      frmMain.DebugLog('      Vraag key..');
      if lForm.ShowModal = mrOk then
      begin
        lbAskIdAgain := False;
        FObjectKey := lForm.NieuweKey;
        frmMain.DebugLog('      Key: ' + IntToStr(FObjectKey));
        if KeyExists then
        begin
          frmMain.DebugLog('      Key bestaat al!');
          lbAskIdAgain := True;
          Messagedlg('Value is already in use', mtError, [mbOk], 0);
        end;
      end
      else
        lbAskIdAgain := False;
    until not lbAskIdAgain;
  finally
    lForm.Release;
  end;

  Result := (FObjectKey > 0);
  frmMain.DebugLog('      Key obtained? = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('    <-- doIntegerObject ObtainKey');
end;

//__________________________________________________________________________________________
function TdoBaseDataObjectInteger.CreateRecord: boolean;
begin
  frmMain.DebugLog('    --> doIntegerObject CreateRecord');
  frmMain.DebugLog('      Key = ' + IntToStr(FObjectKey));
  if FObjectKey <= 0 then
    raise EFmDbFieldRequired.Create(Format(VALUE_REQUIRED, ['Recordnummer']), FKeyField);

  with qryInsert do
    begin
      Close;
      ParamByName('prm' + FKeyField).AsInteger := FObjectKey;
      ExecSQL;
    end;

  RefreshLijst;

  LocateObject([FObjectKey]);

  frmMain.DebugLog('    <-- doIntegerObject CreateRecord');
end;

//__________________________________________________________________________________________
function TdoBaseDataObjectInteger.KeyExists : Boolean;
begin
	with qryCheckKey do
  begin
  	Close;
    ParamByName( 'prm' + FKeyField ).AsInteger := FObjectKey;
    Open;

    Result := (RecordCount > 0);

    Close;
  end;
end;

//__________________________________________________________________________________________
function TdoBaseDataObjectInteger.LocateObject(aKeyValues: array of const): Boolean;
var
  lBookmark : TBookmark;
begin
  frmMain.DebugLog('--> doIntegerObject LocateObject');
  Result := False;

  if High( aKeyValues ) < 0 then
    raise EFmDbInsufficientParameters.Create( 'Onvoldoende parameters voor opvragen record' );

	with qryLijst do
    begin
      try
        DisableControls;
        dtsLijst.Dataset := nil;

        lBookmark := GetBookmark;

        frmMain.DebugLog('  Looking for: ' + IntToStr(aKeyValues[0].VInteger));
        First;
        while (not Result) and (not Eof) do
          begin
            if FieldByName(FKeyField).AsInteger = aKeyValues[0].VInteger then
              Result := True
            else
              Next;
          end;

        if not Result then
          GotoBookmark(lBookmark)
        else
          SelectObject;
      finally
        EnableControls;
        dtsLijst.Dataset := qryLijst;
        FreeBookmark(lBookmark);
      end;
    end;
  frmMain.DebugLog('      Record located? = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('<-- doIntegerObject LocateObject');
end;

end.

January 17, 2021

Bedankt. Hier een aantal functies:

unit fBaseDataObject;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls, 
  Forms, Dialogs, DB, DBTables, Wwdatsrc, Wwquery;

type
  TdoBaseDataObject = class(TDataModule)
    qryLijst      : TwwQuery;
    qryObject     : TwwQuery;
    dtsLijst      : TwwDataSource;
    qryInsert     : TwwQuery;
    qryUpdate     : TwwQuery;
    qryDelete     : TwwQuery;
    qryDeleteAll  : TwwQuery;
    qryCheckKey   : TwwQuery;
    qryGetLastKey : TwwQuery;
  private
  protected
    FTableName : string;
    FKeyField  : string;
    FNameField : string;

    FNewCaption : string;
    FNewKeyName : string;

    { genereren we een key zelf of vragen we de gebruiker }
    FAutoGenerateKey : boolean;
    { zijn we bezig een record toe te voegen }
    FInserting    : boolean;
    FWasInserting : boolean;
    { mogen we een database actie doen }
    function CanInsert : Boolean; virtual;
    function CanUpdate : Boolean; virtual;
    function CanPost : Boolean; virtual;
    function CanDelete : Boolean; virtual;
    { haal de nieuwe key op voor een insert }
    procedure GenerateKey; virtual; abstract;

    function ObtainKey: boolean; virtual; abstract;
    function KeyExists : Boolean; virtual; abstract;

    function CreateRecord: boolean; virtual; abstract;

    function Getstate: TDatasetState; virtual;

    procedure LijstRecordChanged(aSender: TObject; aField: TField); virtual;

    procedure SetAutoGenerateKey(aValue: boolean); virtual;

    function GetObjectIsValid: boolean;

  public
    constructor Create( AOwner : TComponent; aTableName,
      aKeyField, aNameField, aNewCaption, aNewKeyName: string ); virtual;

    constructor CreateObject(aOwner: TComponent); virtual; abstract;

    destructor Destroy; override;

    function CanClose: boolean;

    function Insert: boolean; virtual;
    function Edit: boolean; virtual;
    function Cancel: boolean; virtual;
    function Post: boolean; virtual;
    function Delete: boolean; virtual;
    function DeleteAll : Integer; virtual;

    function GetLijst : TwwQuery; virtual;
    procedure CloseLijst; virtual;
    procedure RefreshLijst; virtual;

    function GetObject : TwwQuery; virtual;
    procedure SelectObject; virtual; abstract;
    function LocateObject(aKeyValues: array of const): Boolean; virtual; abstract;

    property State: TDatasetState read Getstate;
    property AutoGenerateKey: boolean read FAutoGenerateKey write SetAutoGenerateKey;
    property ObjectIsValid: boolean read GetObjectIsValid;
  end;

  {var
    DataObject: TDataObject;}

implementation

{$R *.DFM}

uses
  fmConsts, fmMain;

//__________________________________________________________________________________________
function TdoBaseDataObject.CanClose: boolean;
var
  Resultaat : Word;
begin
  Result := true;

  { als de data wordt bewerkt, vraag dan of de veranderingen bewaard moeten worden }
  if (State = dsInsert) or
     (State = dsEdit) then
    begin
      Resultaat := MessageDlg(CONFIRM_APPLY_CHANGES, mtConfirmation, mbYesNoCancel, 0);
      if Resultaat = mrCancel then
        Result := False
      else
        if Resultaat = mrYes then
          Result := Post
        else
          Result := Cancel;
    end;
end;

//__________________________________________________________________________________________
constructor TdoBaseDataObject.Create( AOwner : TComponent;
  aTableName, aKeyField, aNameField, aNewCaption, aNewKeyName: string );
begin
  frmMain.DebugLog('      --> DataObject Create');
  inherited Create( AOwner );

  FTableName := aTableName;
  FKeyField  := aKeyField;
  FNameField := aNameField;

  FNewCaption := aNewCaption;
  FNewKeyName := aNewKeyName;

  { we zijn geen record aan het toevoegen }
  FInserting    := False;
  FWasInserting := False;
  { vraag een nieuwe key aan de gebruiker bij het toevoegen }
  FAutoGenerateKey := False;
  frmMain.DebugLog('      <-- DataObject Create');
end;

//__________________________________________________________________________________________
procedure TdoBaseDataObject.LijstRecordChanged(aSender: TObject; aField: TField);
begin
  {frmMain.DebugLog('--> DataObject LijstRecordChanged');}
  SelectObject;
  {frmMain.DebugLog('<-- DataObject LijstRecordChanged');}
end;

//__________________________________________________________________________________________
destructor TdoBaseDataObject.Destroy;
var
  lintCounter : integer;
begin
  if (State = dsInsert) or
     (State = dsEdit) then
    Cancel;

  { close all the opened datasets }
  for lintCounter := ComponentCount - 1 downto 0 do
    if Components[lintCounter] is TwwQuery then
      begin
        TwwQuery(Components[lintCounter]).Close;
        TwwQuery(Components[lintCounter]).Unprepare;
        //TwwQuery(Components[lintCounter]).Free;
      end;

  inherited Destroy;
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.GetState: TDatasetState;
begin
  if FInserting then
    Result := dsInsert
  else
    Result := qryObject.State;
end;

//__________________________________________________________________________________________
procedure TdoBaseDataObject.SetAutoGenerateKey(aValue: boolean);
begin
  if (aValue <> FAutoGenerateKey) and
     not FInserting then
    FAutoGenerateKey := aValue;
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.GetObjectIsValid: boolean;
begin
  frmMain.DebugLog('--> DataObject GetObjectIsValid');
  Result := ((State <> dsInactive) and not
             (qryObject.Bof and qryObject.Eof));
  frmMain.DebugLog('<-- DataObject GetObjectIsValid');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.CanInsert: boolean;
begin
  frmMain.DebugLog('    --> DataObject CanInsert');
  Result := True;

  { kijk of we niet aan het editen of inserten zijn }
  if (State = dsInsert) or
       (State = dsEdit) then
    Result := False;

  frmMain.DebugLog('      CanInsert = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('    <-- DataObject CanInsert');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.CanUpdate: boolean;
begin
  frmMain.DebugLog('    --> DataObject CanUpdate');
  Result := True;
  { kijk of we niet aan het editen of inserten zijn }
  if FInserting or
       (State <> dsBrowse) then
    Result := False;
  frmMain.DebugLog('      CanUpdate? = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('    <-- DataObject CanUpdate');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.CanPost: boolean;
begin
  frmMain.DebugLog('    --> DataObject CanPost');
  Result := True;
  { kijk of we aan het editen of inserten zijn }
  if (State <> dsInsert) and
       (State <> dsEdit) then
    Result := False;
  frmMain.DebugLog('      CanPost? = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('    <-- DataObject CanPost');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.CanDelete: boolean;
begin
  frmMain.DebugLog('    --> DataObject CanDelete');
  Result := True;
  { kijk of er een record is en of we niet aan het editen of inserten zijn }
  if FInserting or
       (State <> dsBrowse) or
       (qryObject.Bof and qryObject.Eof) then
    Result := False;

  frmMain.DebugLog('      CanDelete? = ' + IntToStr(Integer(Result)));
  frmMain.DebugLog('    <-- DataObject CanDelete');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.Insert: boolean;
var
  lbDoInsert : boolean;
begin
  frmMain.DebugLog('  --> DataObject Insert');
  lbDoInsert := True;
  { kijk of een nieuw record toegevoegd mag worden }
  if CanInsert then
    begin
      { als we automatisch een key moeten genereren }
      if FAutoGenerateKey then
        begin
          { maak dan zelf een key aan }
          frmMain.DebugLog('    Key genereren');
          GenerateKey;
        end
      else
        begin
          { en vraag anders een key aan de gebruiker }
          frmMain.DebugLog('    Key aan gebruiker vragen');
          lbDoInsert := ObtainKey;
        end;

      if lbDoInsert then
        begin
          { en voeg het record toe (en selecteer deze!) }
          frmMain.DebugLog('    Create record');
          CreateRecord;

          { en maak er een insert actie van }
          {qryObject.Edit;}
          FInserting := True;
        end;
    end;

  Result := FInserting;

  if Result then
    frmMain.DebugLog('    Insert ok')
  else
    frmMain.DebugLog('    Insert failed!');
  frmMain.DebugLog('  <-- DataObject Insert');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.Edit: boolean;
begin
  frmMain.DebugLog('--> DataObject Edit');
  Result := False;
  { kijk of het record bewerkt mag worden }
  if CanUpdate then
    begin
      qryObject.Edit;
      Result := True;
      frmMain.DebugLog('  Editing record');
    end;
  frmMain.DebugLog('<-- DataObject Edit');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.Post: boolean;
begin
  frmMain.DebugLog('--> DataObject Post');
  Result := False;
  if CanPost then
    begin
      frmMain.DebugLog('  Posting record');

      FInserting := False;
      qryObject.Post;

      Result := True;

      frmMain.DebugLog('  Refreshing list');
      if qryLijst.Active then
        RefreshLijst;
    end;
  frmMain.DebugLog('<-- DataObject Post');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.Delete: boolean;
begin
  frmMain.DebugLog(' --> DataObject Delete');
  Result := False;
  try
    if FWasInserting or (MessageDlg(CONFIRM_DELETE_DATA, mtConfirmation, [mbYes, mbNo], 0) = mrYes) then
      begin
        if FWasInserting or CanDelete then
          begin
            qryObject.Delete;

            Result := True;
            frmMain.DebugLog('   Record deleted!');

            if qryLijst.Active then
              RefreshLijst;
          end
        else
          MessageDlg(DELETE_OBJECT_REFERENCED, mtError, [mbOk], 0);
      end;
  finally
    FWasInserting := False;
  end;
  frmMain.DebugLog(' <-- DataObject Delete');
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.DeleteAll : Integer;
begin
  with qryLijst do
    begin
      try
        DisableControls;
        Open;

        while not EOF do
          begin
            if CanDelete then
              Delete
            else
              Next;
          end;
      finally
        EnableControls;
        Result := RecordCount;
        Close;
      end;
    end;
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.GetLijst : TwwQuery;
begin
  frmMain.DebugLog('--> DataObject GetLijst');
  qryLijst.Open;
  Result := qryLijst;
  frmMain.DebugLog('<-- DataObject GetLijst');
end;

//__________________________________________________________________________________________
procedure TdoBaseDataObject.CloseLijst;
begin
  qryLijst.Close;
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.GetObject : TwwQuery;
begin
  if not qryLijst.Active then
    qryLijst.Open;
  Result := qryObject;
end;

//__________________________________________________________________________________________
procedure TdoBaseDataObject.RefreshLijst;
begin
  qryLijst.Close;
  qryLijst.Open;
end;

//__________________________________________________________________________________________
function TdoBaseDataObject.Cancel: boolean;
var
  lWasInserting : boolean;
begin
  frmMain.DebugLog('--> DataObject Cancel');
  Result := False;
  if (State = dsInsert) or
     (State = dsEdit) then
    begin
      lWasInserting := (State = dsInsert);
      FInserting    := False;
      qryObject.Cancel;
      if lWasInserting then
        begin
          FWasInserting := True;
          Delete;
        end;
      Result := true;
    end;
  frmMain.DebugLog('<-- DataObject Cancel');
end;

end.

Het formulier met de queries:

January 16, 2021

Bedankt. Ik bouw het verder rustig op. Van algemene opzet naar specifiek detail. De 2 knoppen doen, geloof ik, niet wat beloofd wordt en zijn uitgezet:

unit fmoptions;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls, Buttons;

type
  TfrmOptions = class(TForm)
    SpeedButton1: TSpeedButton;
    SpeedButton2: TSpeedButton;
    GroupBox1: TGroupBox;
    chbMRUPath: TCheckBox;
    procedure FormCreate(Sender: TObject);
    procedure SpeedButton2Click(Sender: TObject);
    procedure SpeedButton1Click(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  frmOptions: TfrmOptions;

implementation

uses fmmain;

{$R *.DFM}

procedure TfrmOptions.FormCreate(Sender: TObject);
begin
//  chbMRUPath.Checked := frmMain.mruDB.ShowPath;
end;

procedure TfrmOptions.SpeedButton2Click(Sender: TObject);
begin
  ModalResult := mrCancel;
end;

procedure TfrmOptions.SpeedButton1Click(Sender: TObject);
begin
//  frmMain.mruDB.ShowPath := chbMRUPath.Checked;
  ModalResult := mrCancel;
end;

end.

Het formulier is zo:

January 15, 2021

De volgende snippet:

unit fdoDatabase;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  DBTables, DB;

type
  TdoDatabase = class(TDataModule)
    dbsFootman : TDatabase;
  private
    procedure SetDatabasePath(const Value: string);
    function GetDatabasePath: string;
    function GetActive: boolean;
    procedure SetActive(const Value: boolean);
    { Private declarations }
  public
    { Public declarations }
    constructor Create(aOwner: TComponent); override;

    property DatabasePath: string read GetDatabasePath write SetDatabasePath;
    property Active: boolean read GetActive write SetActive;
  end;

var
  doDatabase: TdoDatabase;
  
implementation

{$R *.DFM}

//__________________________________________________________________________________________
constructor TdoDatabase.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  // disconnect the database
  dbsFootman.Close;
end;

//__________________________________________________________________________________________
function TdoDatabase.GetActive: boolean;
begin
  Result := dbsFootman.Connected;
end;

//__________________________________________________________________________________________
function TdoDatabase.GetDatabasePath: string;
begin
  Result := dbsFootman.Params.Values['path'];
end;

//__________________________________________________________________________________________
procedure TdoDatabase.SetActive(const Value: boolean);
begin
  dbsFootman.Connected := Value;
end;

//__________________________________________________________________________________________
procedure TdoDatabase.SetDatabasePath(const Value: string);
begin
  if Value <> GetDatabasePath then
    begin
      // disconnect the database
      dbsFootman.Connected := False;
      // and set the database to the new path
      dbsFootman.Params.Values['path'] := Value;
    end;
end;

end.

Wat gebeurt hier? Het formulier met de TDatabase:

January 14, 2021

In de eerste plaats bedankt voor de tijd en moeite, die je neemt om de code uit te leggen, emailx45. Lovenswaardig. (((Ik ben trouwens niet diegene van mijn foto. De foto is een eerbetoon aan die persoon zelf.))) Ik ga proberen elke dag een snippet te plaatsen. Ik hoop dat je de tijd en energie kan vinden. Ik weet niet of we het volhouden. Er zijn aardig wat forms te bespreken. Je bent natuurlijk niet verplicht. We zien wel. Ik sla fmseason even over voor dit moment. Laten we verder gaan met het eenvoudige fmabout:

unit fmabout;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ComCtrls, StdCtrls, Buttons;

type
  TFormAbout = class(TForm)
    BBtnOk: TBitBtn;
    PhysMem: TLabel;
    PhysFre: TLabel;
    MemFree: TProgressBar;
    Label1: TLabel;
    Label2: TLabel;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure BBtnOkClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

var
  FormAbout: TFormAbout;

implementation

{$R *.DFM}

procedure TFormAbout.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  Action:=caFree;
end;

procedure TFormAbout.BBtnOkClick(Sender: TObject);
begin
  Close;
end;

end.

De code spreekt eigenlijk voor zich. Maar toch graag uitleg van de 2 genoemde procedures. Het formulier ziet er zo uit:

January 14, 2021

14 hours ago, Stano said:

Where is the published code from? Own? Probably not. Do you have experience with programming? If so, which ones? In any case, I very hard recommend you

http://docwiki.embarcadero.com/Libraries/Sydney/en/Main_Page

The code is from around 1998 to 2000. It is the code for the program called FOOTMAN. And it is unique. It was not written by me. But I (co)own the code.

January 13, 2021

Duidelijk. Het zou dus beter zijn om de formulieren later te creëeren. Op het moment dat ze werkelijk nodig zijn. Laten we verder gaan met fmmain:

unit fmmain;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Menus, ComCtrls, ToolWin, StdCtrls, ImgList, StdActns, ActnList, RzPanel, 
  Buttons, ExtCtrls, RzStatus, fdoDatabase;

const
  MINFORMHEIGHT   = 300;
  MINFORMWIDTH    = 400;
  NORMALFORMHEIGHT= 475;
  NORMALFORMWIDTH = 635;

type
  TfrmMain = class(TForm)
    MainMenu           : TMainMenu;
    MnuFile            : TMenuItem;
    MnuNew             : TMenuItem;
    MnuOpen            : TMenuItem;
    MnuClose           : TMenuItem;
    N1                 : TMenuItem;
    MnuExit            : TMenuItem;
    MnuDatabase        : TMenuItem;
    OpenDialog         : TOpenDialog;
    ToolBar1           : TToolBar;
    ToolButton1        : TToolButton;
    ToolButton2        : TToolButton;
    ToolButton3        : TToolButton;
    ToolButton4        : TToolButton;
    ImageList1         : TImageList;
    ImageList2         : TImageList;
    btnDatabase        : TToolButton;
    PMDatabase         : TPopupMenu;
    PMSeasons          : TMenuItem;
    PMBasicData        : TMenuItem;
    mniBasic           : TMenuItem;
    mniReopen          : TMenuItem;
    mniSaveAs          : TMenuItem;
    mniAllSeasons      : TMenuItem;
    mniActiveSeason    : TMenuItem;
    mniSeasons         : TMenuItem;
    mniHelp            : TMenuItem;
    mniAbout           : TMenuItem;
    N2                 : TMenuItem;
    mniContents        : TMenuItem;
    mniTools           : TMenuItem;
    mniOptions         : TMenuItem;
    N3                 : TMenuItem;
    mniDBProperties    : TMenuItem;
    ImageList3         : TImageList;
    aclMenu            : TActionList;
    actEditCopy        : TEditCopy;
    actEditCut         : TEditCut;
    actEditPaste       : TEditPaste;
    imlMenu            : TImageList;
    mniEdit            : TMenuItem;
    actUndo            : TAction;
    actRepeat          : TAction;
    Cut1               : TMenuItem;
    Copy1              : TMenuItem;
    Paste1             : TMenuItem;
    Undo1              : TMenuItem;
    Repeat1            : TMenuItem;
    actNewDatabase     : TAction;
    actOpenDatabase    : TAction;
    actReopenDatabase  : TAction;
    actSaveDatabase    : TAction;
    actCloseDatabase   : TAction;
    StatusBar          : TRzStatusBar;
    stsSeasonName      : TRzStatusPane;
    stsDetails         : TRzStatusPane;
    RzKeyStatus1       : TRzKeyStatus;
    RzKeyStatus2       : TRzKeyStatus;
    RzKeyStatus3       : TRzKeyStatus;
    RzClockStatus1     : TRzClockStatus;
    actViewToolBarEdit : TAction;
    mniView            : TMenuItem;
    ShowEdittoolbar1   : TMenuItem;
    mniWindow          : TMenuItem;
    Debuglog1          : TMenuItem;
    procedure MnuOpenClick(Sender: TObject);
    procedure MnuExitClick(Sender: TObject);
    procedure DisplayHint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure MnuNewClick(Sender: TObject);
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure MnuCloseClick(Sender: TObject);
    procedure mniBasicClick(Sender: TObject);
    procedure mniActiveSeasonClick(Sender: TObject);
    procedure mruDBSelectFile(Sender: TObject; FileName: String);
    procedure mniOptionsClick(Sender: TObject);
    procedure mniDBPropertiesClick(Sender: TObject);
    procedure actNewDatabaseHint(var HintStr: String;
      var CanShow: Boolean);
    procedure Debuglog1Click(Sender: TObject);
    procedure mniAllSeasonsClick(Sender: TObject);
  private
    FdoDatabase : TdoDatabase;

    FDateFormat : string;
    // active season information
    FActiveCompetitionIdx : Integer;
    FActiveSeasonIdx      : Integer;
    FActiveSeasonName     : string;
    // active database information
    FDatabaseActive : boolean; // is database active
    FDatabasePath : string; // stored path to data
    FDatabaseName : string; // name of main database file
    FTableNamePrefix : string; // table name prefix
    procedure OpenDatabase(DBName: string);
  public
    SeasonOpen : boolean;
    function FormExist(FormName: string): boolean;
    procedure UpdateWindowList;
    procedure DebugLog(aLine: string);
    constructor Create(aOwner: TComponent); override;
  published
    // the database object
    property doDatabase : TdoDatabase read FdoDatabase;
    property DateFormat : string      read FDateFormat write FDateFormat;
    // active season information
    property ActiveCompetition : integer read FActiveCompetitionIdx write FActiveCompetitionIdx;
    property ActiveSeason      : integer read FActiveSeasonIdx      write FActiveSeasonIdx;
    property ActiveSeasonName  : string  read FActiveSeasonName     write FActiveSeasonName;
    // active database information
    property DatabaseActive  : boolean read FDatabaseActive  write FDatabaseActive;
    property DatabasePath    : string  read FDatabasePath    write FDatabasePath;
    property DatabaseName    : string  read FDatabaseName    write FDatabaseName;
    property TableNamePrefix : string  read FTableNamePrefix write FTableNamePrefix;
  end;

var
  frmMain : TfrmMain;

implementation

uses
  fmseason, fmabout, fmdmbasic, 
  fmbasicdata, fmseasonview, fmdmprop, fmoptions, fmdbprop, fmmatch, dstat, 
  fmconsts, fDebugLog;

{$R *.DFM}

//__________________________________________________________________________________________
constructor TfrmMain.Create(aOwner: TComponent);
begin
  inherited Create(aOwner);
  // create the database object
  FdoDatabase := TdoDatabase.Create(Self);
end;

//__________________________________________________________________________________________
procedure TfrmMain.MnuOpenClick(Sender: TObject);
begin
  if MDIChildCount > 0 then
    MessageDlg('Please close all windows first', mtInformation, [mbOk], 0)
  else
    begin
      if frmMain.DatabaseActive then
        if MessageDlg('Do you want to close the current database?',
                      mtConfirmation, mbYesNoCancel, 0) <> mrYes then
          Exit;
      if OpenDialog.Execute then
        OpenDatabase(OpenDialog.FileName);
    end;
end; // MnuOpenClick

//__________________________________________________________________________________________
procedure TfrmMain.OpenDatabase(DBName: string);
begin
  if (BasicData.OpenDatabase(DBName) < ERROR_NO_ERROR) then
    MessageDlg('An error occured opening the database', mtError, [mbOk], 0)
  else
    begin
      //    mruDB.AddFile(DBName);
      btnDatabase.Enabled     := true;
      //mnuCompetitions.Enabled := true;
      mniBasic.Enabled        := true;
      PMSeasons.Enabled       := true;
      PMBasicData.Enabled     := true;
      mnuClose.Enabled        := true;
      mniAllSeasons.Enabled   := true;
      mniActiveSeason.Enabled := true;
      mniDBProperties.Enabled := true;
    end;
end;

//__________________________________________________________________________________________
procedure TfrmMain.MnuExitClick(Sender: TObject);
begin
  Close;
end; // MnuExitClick

//__________________________________________________________________________________________
procedure TfrmMain.DisplayHint(Sender: TObject);
begin
  if Application.Hint <> '' then
    stsSeasonName.Caption := Application.Hint
  else
    stsSeasonName.Caption := ActiveSeasonName;
end; // DisplayHint

//__________________________________________________________________________________________
procedure TfrmMain.FormCreate(Sender: TObject);
begin
  Application.OnHint := DisplayHint;
  ActiveSeason       := -1;
  ActiveSeasonName   := '';
  ActiveCompetition  := -1;
  Height             := NORMALFORMHEIGHT;
  Width              := NORMALFORMWIDTH;
  FDateFormat        := ShortDateFormat; //'dd-mm-yyyy';
  //ShortDateFormat:='dd-mm-yyyy'; //FDateFormat;
  //UpdateFormatSettings:=False;
  SeasonOpen := false;
  dtmStat    := nil;
end; // FormCreate

//__________________________________________________________________________________________
procedure TfrmMain.MnuNewClick(Sender: TObject);
begin
  //ShowMessage(Data.Database.Params[0]);
end; // MnuNewClick

//__________________________________________________________________________________________
procedure TfrmMain.FormClose(Sender: TObject; var Action: TCloseAction);
begin
  //dtmProp.CloseQueries;
  //dtmStat.CloseQueries;
  //BasicData.CloseDatabase;
end; // FormClose

//__________________________________________________________________________________________
procedure TfrmMain.MnuCloseClick(Sender: TObject);
begin
  Basicdata.CloseDatabase;
  btnDatabase.Enabled     := false;
  //mnuCompetitions.Enabled := false;
  mniBasic.Enabled        := false;
  PMSeasons.Enabled       := false;
  PMBasicData.Enabled     := false;
  mnuClose.Enabled        := false;
  mniAllSeasons.Enabled   := false;
  mniActiveSeason.Enabled := false;
  mniDBProperties.Enabled := false;
end; // MnuCloseClick

//__________________________________________________________________________________________
procedure TfrmMain.mniBasicClick(Sender: TObject);
begin
  if MDIChildCount > 0 then
    MessageDlg('Please close other windows first', mtInformation, [mbOk], 0)
  else
    begin
      try
        Screen.Cursor := crHourGlass;
        Application.CreateForm(TFormBasicData, FormBasicData);
        MniBasic.Checked    := True;
        PMBasicData.Checked := True;
        FormBasicData.Show;
      finally
        Screen.Cursor := crDefault;
      end;
    end;
end; // mniBasicClick

//__________________________________________________________________________________________
procedure TfrmMain.mniActiveSeasonClick(Sender: TObject);
begin
  if ActiveSeason<0 then
    begin
      MessageDlg('No season selected', mtInformation, [mbOk], 0);
      Exit;
    end;
  if not SeasonOpen then
    begin
      try
        Screen.Cursor := crHourGlass;
        Application.CreateForm(TfrmSeasonView, frmSeasonView);
        frmSeasonView.InitializeForm;
        //frmSeasonView.ResetForm(Self);
        SeasonOpen := true;
      finally
        Screen.Cursor := crDefault;
      end;
    end;
  frmSeasonView.Show;
end; // mniActiveSeasonClick

//__________________________________________________________________________________________
function TfrmMain.FormExist(FormName: string): boolean;
var
  i         : integer;
  FoundForm : boolean;
begin
  FoundForm := false;
  i         := 0;
  while (not FoundForm) and (i < MDIChildCount) do
    begin
      if (UpperCase(MDIChildren[i].Name) = UpperCase(FormName)) then
        FoundForm := true;
      Inc(i);
    end;
  Result := FoundForm;
end; // FormExist

//__________________________________________________________________________________________
procedure TfrmMain.mruDBSelectFile(Sender: TObject; FileName: String);
begin
  OpenDatabase(FileName);
end; // mruDBSelectFile

//__________________________________________________________________________________________
procedure TfrmMain.mniOptionsClick(Sender: TObject);
begin
  Application.CreateForm(TfrmOptions, frmOptions);
  frmOptions.ShowModal;
end; // mniOptionsClick

//__________________________________________________________________________________________
procedure TfrmMain.mniDBPropertiesClick(Sender: TObject);
begin
  try
    Cursor := crHourGlass;
    if not FormExist('frmDBProperties') then
      Application.CreateForm(TfrmDBProperties, frmDBProperties);
  finally
    Cursor := crDefault;
  end;
  frmDBProperties.Show;
end; // mniDBPropertiesClick

//__________________________________________________________________________________________
procedure TfrmMain.actNewDatabaseHint(var HintStr: String;
  var CanShow: Boolean);
begin
  HintStr := 'Create a new database';
  CanShow := true;
end; // actNewDatabaseHint

//__________________________________________________________________________________________
procedure TfrmMain.UpdateWindowList;
begin
  // maak de lijst leeg
  {mniWindow.Clear;
  for ChildNr := 0 to MDIChildCount - 1 do
  begin
  end;}
end; // UpdateWindowList

//__________________________________________________________________________________________
procedure TfrmMain.DebugLog(aLine: string);
begin
  // write line to debug log
  frmDebugLog.WriteToDebugLog(aLine);
  Application.ProcessMessages;
end;

//__________________________________________________________________________________________
procedure TfrmMain.Debuglog1Click(Sender: TObject);
begin
  if USE_DEBUG_LOG then
    begin
      frmDebugLog.Show;
      Left := frmDebuglog.width + 5;
      SetFocus;
    end;
end;

procedure TfrmMain.mniAllSeasonsClick(Sender: TObject);
begin
  if MDIChildCount > 0 then
    MessageDlg('Please close all windows first', mtInformation, [mbOk], 0)
  else
    begin
     // if not MnuCompetitions.Checked then
        begin
          LockWindowUpdate(Handle);
          Application.CreateForm(TFormSeasons, FormSeasons);
          LockWindowUpdate(0);
          //MnuCompetitions.Checked := True;
          PMSeasons.Checked       := True;
          FormSeasons.Top         := FormSeasons.Top div 2;
        end;
      FormSeasons.Show;
    end;
end;

end.

Misschien teveel code tegelijk. Maar ik zou graag van elke procedure iets willen begrijpen. Het formulier ziet er zo uit:

January 13, 2021

Een professional inhuren voor een privé project is niet te doen. Ik zal dus Delphi zelf moeten leren. Laten we eenvoudig beginnen:

program footman;

uses
  Forms,
  fmmain in 'fmmain.pas' {frmMain},
  fmseason in 'fmseason.pas' {FormSeasons},
  fmpropcompetition in 'fmpropcompetition.pas' {FormPropCompetition},
  fmabout in 'fmabout.pas' {FormAbout},
  fmpropstadium in 'fmpropstadium.pas' {FormPropStadium},
  fmpropplayer in 'fmpropplayer.pas' {FormPropPlayer},
  fmpropcountry in 'fmpropcountry.pas' {FormPropCountry},
  fmpropreferee in 'fmpropreferee.pas' {FormPropReferee},
  fmpropteam in 'fmpropteam.pas' {FormPropTeam},
  fmpropround in 'fmpropround.pas' {frmPropRound},
  fmpageteam in 'fmpageteam.pas' {FormPageBaseTeam},
  fmpageplayer in 'fmpageplayer.pas' {FormPageBasePlayer},
  fmpagereferee in 'fmpagereferee.pas' {FormPageBaseReferee},
  fmpagestadium in 'fmpagestadium.pas' {FormPageBaseStadium},
  fmpagecountry in 'fmpagecountry.pas' {FormPageBaseCountry},
  fmdmbasic in 'fmdmbasic.pas' {BasicData: TDataModule},
  fmpageposition in 'fmpageposition.pas' {FormPageBasePosition},
  fmpagesystem in 'fmpagesystem.pas' {FormPageBaseSystem},
  fmpagecoach in 'fmpagecoach.pas' {FormPageBaseCoach},
  fmpropcoach in 'fmpropcoach.pas' {FormPropCoach},
  fmnewstadiumname in 'fmnewstadiumname.pas' {FormRenameStadium},
  fmconsts in 'fmconsts.pas',
  fmseasonteam in 'fmseasonteam.pas' {frmSeasonTeam},
  fmseasonplayer in 'fmseasonplayer.pas' {frmSeasonPlayer},
  fmseasoncoach in 'fmseasoncoach.pas' {frmSeasonCoach},
  fmseasonreferee in 'fmseasonreferee.pas' {frmSeasonReferee},
  fmseasonstadium in 'fmseasonstadium.pas' {frmSeasonStadium},
  fRenameTeam in 'fRenameTeam.pas' {frmRenameTeam},
  fmround in 'fmround.pas' {frmRounds},
  fmmatch in 'fmmatch.pas' {frmMatch},
  fmseasonview in 'fmseasonview.pas' {frmSeasonView},
  fmdmprop in 'fmdmprop.pas' {dtmProp: TDataModule},
  fmoptions in 'fmoptions.pas' {frmOptions},
  fmdbprop in 'fmdbprop.pas' {frmDBProperties},
  fdbinfothread in 'fdbinfothread.pas',
  fmatchview in 'fmatchview.pas' {frmMatchView},
  dstat in 'dstat.pas' {dtmStat: TDataModule},
  sqlconst in 'sqlconst.pas',
  fmatchedit in 'fmatchedit.pas' {frmMatchEdit},
  fSeasonViewDraft in 'fSeasonViewDraft.pas' {frmSeasonViewDraft},
  dSeason in 'dSeason.pas' {dtmSeason: TDataModule},
  dMatch in 'dMatch.pas' {dtmMatch: TDataModule},
  fNewPlayerNr in 'fNewPlayerNr.pas' {frmNewPlayerNr},
  fmbasicdata in 'fmbasicdata.pas' {FormBasicData},
  fdoDatabase in 'fdoDatabase.pas' {doDatabase: TDataModule},
  fNewSeasonProperties in 'fNewSeasonProperties.pas' {frmNewSeasonProperties},
  fDebugLog in 'fDebugLog.pas' {frmDebugLog},
  fBaseDataObject in 'fBaseDataObject.pas' {doBaseDataObject},
  fBaseDataObjectInteger in 'fBaseDataObjectInteger.pas' {doBaseDataObjectInteger: TDataModule},
  fDoSeason in 'fDoSeason.pas' {doSeason: TDataModule},
  fSeasonRound in 'fSeasonRound.pas' {frmSeasonRound},
  fDoMatch in 'fDoMatch.pas' {doMatch: TDataModule},
  dMatchNew in 'dMatchNew.pas' {dtmMatchNew: TDataModule},
  fmatch in 'fmatch.pas' {frmMatchNew};

{$R *.RES}

begin
  Application.Initialize;
  Application.CreateForm(TfrmMain, frmMain);
  Application.CreateForm(TdoDatabase, doDatabase);
  Application.CreateForm(TdtmProp, dtmProp);
  Application.CreateForm(TdtmStat, dtmStat);
  Application.CreateForm(TdtmSeason, dtmSeason);
  Application.CreateForm(TBasicData, BasicData);
  Application.CreateForm(TdtmMatch, dtmMatch);
  Application.CreateForm(TfrmDebugLog, frmDebugLog);
  Application.Run;
end.

Kan iemand mij in gewoon nederlands kort uitleggen wat hier gebeurt, a.u.b.?

Sign In

Johnny Smash

Content Count

Joined

Last visited

Content Type

Profiles

Forums

Calendar

Posts posted by Johnny Smash

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Footman

Browse

Activity