Jump to content

Johnny Smash

Members
  • Content Count

    18
  • Joined

  • Last visited

Everything posted by Johnny Smash

  1. Johnny Smash

    Footman

    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.?
  2. Johnny Smash

    Footman

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

    Footman

    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?
  4. Johnny Smash

    Footman

    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?
  5. Johnny Smash

    Footman

    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.
  6. Johnny Smash

    Footman

    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.
  7. Johnny Smash

    Footman

    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.
  8. Johnny Smash

    Footman

    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.
  9. Johnny Smash

    Footman

    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.
  10. Johnny Smash

    Footman

    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.
  11. Johnny Smash

    Footman

    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.
  12. Johnny Smash

    Footman

    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.
  13. Johnny Smash

    Footman

    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:
  14. Johnny Smash

    Footman

    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:
  15. Johnny Smash

    Footman

    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:
  16. Johnny Smash

    Footman

    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:
  17. Johnny Smash

    Footman

    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.
  18. Johnny Smash

    Footman

    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:
×