vwemirror/TeslaRel410
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
110ecec2ca3edc135e260e0f3ee07e7945cbf4ec
TeslaRel410/BORLAND/BDE/EXAMPLES/PASCAL/EMPLOYEE/EMPLOYEE.PAS
T
CydandClaude Fable 5 63312e07f9 source410: literal 4.10 source reconstruction + BC++ 4.52 fleet toolchain archived 
- BORLAND/: Borland C++ 4.52 (chosen over 4.5 by byte-match: CODE/RP/CW32.LIB
  is identical to 4.52's install lib). BCC32/TLINK32/TLIB/MAKE run natively on
  Win11; CODE/BT/OPT.MAK is the shipped BTL4OPT.EXE's exact flag recipe
  (extender = Borland PowerPack DPMI32, not Phar Lap TNT).
- restoration/source410/: the literal 1995-form reconstruction of the missing
  BT game source (never mixed into CODE/). Round 1-3 state:
  * 6 of 10 surviving original TUs COMPILE CLEAN under the period toolchain
    (BTMSSN, BTCNSL, BTSCNRL, BTTEAM, BTL4MODE, BTL4ARND) - first builds
    since 1996.
  * BT_L4/BTL4APP.CPP pilot reconstruction: 12/12 functions, Fail() lands on
    its binary-recorded line 400 exactly.
  * BT/BTCNSL.HPP: console wire IDs recovered from the binary's ctors
    (Killed=9, Damaged=10, ScoreUpdate=13, DeathWithoutHonor=15 [T1];
    TeamScore=12 flagged [T4]).
  * MUNGA/: 8 engine-header backfills back-dated from the BT412 WinTesla tree
    (VDATA numbering decomp-verified; AUDREND's OpenAL-era virtual removed -
    the period compiler is the drift detector).
  * Tooling: backdate.py (WinTesla->1995 header transform), compile410.sh
    (per-TU verification sweep under authentic OPT.MAK flags).
  * README: corrected roadmap - MECH.HPP is the capstone grown with the mech
    TU reconstructions; BTREG.CPP green = the header-family milestone.

Co-Authored-By: Claude Fable 5 <noreply@anthropic.com>
2026-07-19 07:33:26 -05:00

935 lines
27 KiB
ObjectPascal
Raw Blame History

{$A+,B-,D+,F+,G+,I-,K+,L+,N+,P-,Q-,R-,S-,T-,V+,W+,X+,Y+}
{$M 25000,8192}
{************************************************}
{ }
{ Demo program }
{ Copyright (c) 1994 by Borland International }
{ }
{************************************************}
program Employee;
{$R EMPLOYEE.RES}
uses WinTypes, WinProcs, WinDos, Strings, OWindows, ODialogs, Engine,
IDAPI, DbiTypes, DbiErrs, EmpConst, BWCC;
const
{ Application name }
TableName = 'Employee.dbf';
file_Handles = 40;
AddMode = 1;
ModMode = 2;
id_FirstRec = 100;
id_PrevRec = 110;
id_NextRec = 120;
id_LastRec = 130;
id_About = 1140;
id_NewRec = 155;
id_DelRec = 165;
id_Exit = 1170;
Id_Filter = 1180;
Id_SaveRec = 190;
Id_Order = 1200;
Id_Range = 1210;
Id_Search = 1220;
Id_UndoRec = 123;
{ Edit box ID's }
IDE_FName = 2000;
IDE_LName = 2001;
IDE_Address1 = 2002;
IDE_Address2 = 2003;
IDE_City = 2004;
IDE_State = 2005;
IDE_Zip = 2006;
IDE_HPhone = 2007;
IDE_WPhone = 2008;
IDE_EmployeeId = 2009;
IDE_StartDate = 2010;
IDE_EndDate = 2011;
IDE_Department = 2012;
IDE_Comments = 2013;
{ Static Text fields }
St_Names = 101;
St_Dates = 102;
{ OrderDialog Controls }
IDC_OrderIdxNames = 103;
IDC_OrderInfo = 104;
{ SearchDialog Controls }
IDC_SearchIdxNames = 101;
IDE_SearchInfo = 103;
type
{ PEmployee dialog window object }
PEmployee = ^TEmployee;
TEmployee = object(TDlgWindow)
TableEmpty: boolean;
Mode: integer;
constructor Init;
procedure SetUpWindow; virtual;
procedure ChangeMode(NewMode: integer);
procedure ClearFields(Rec: PRecordType);
procedure DisplayRecord(Rec: PRecordType);
procedure DisableCommand(CommandId: Integer);
procedure EnableCommand(CommandId: Integer);
procedure EnableControls;
procedure DisableControls;
function verified: boolean;
function GetClassName: PChar; virtual;
procedure GetRec(var Rec: TRecordType);
procedure GetWindowClass(var AWndClass: TWndClass); virtual;
procedure idExit(var Msg: TMessage);
virtual cm_First + id_Exit;
procedure cmAbout(var Msg: TMessage);
virtual cm_First + id_About;
procedure idFirstRec(var Msg: TMessage);
virtual id_First + id_FirstRec;
procedure idLastRec(var Msg: TMessage);
virtual id_First + id_LastRec;
procedure idNextRec(var Msg: TMessage);
virtual id_First + id_NextRec;
procedure idPrevRec(var Msg: TMessage);
virtual id_First + id_PrevRec;
procedure idNewRec(var Msg: TMessage);
virtual id_First + id_NewRec;
procedure idDelRec(var Msg: TMessage);
virtual id_First + id_DelRec;
procedure idOrder(var Msg: TMessage);
virtual cm_First + id_Order;
procedure idSaveRec(var Msg: TMessage);
virtual id_First + id_SaveRec;
procedure idSearch(var Msg: TMessage);
virtual cm_First + id_Search;
procedure idUndoRec(var Msg: TMessage);
virtual id_First + id_UndoRec;
procedure WmDisplay(var Msg: TMessage);
virtual wm_First + wm_Display;
procedure wmCommand(var Msg: TMessage);
virtual wm_First + wm_Command;
procedure OK(var Msg: TMessage);
virtual id_First + id_OK;
procedure Cancel(var Msg: TMessage);
virtual id_First + id_Cancel;
procedure WMClose(var Msg: TMessage);
virtual wm_First + wm_Close;
end;
{ Index Order Dialog Definition }
POrderDialog = ^TOrderDialog;
TOrderDialog = object(TDialog)
constructor Init;
procedure SetupWindow; virtual;
procedure WMCommand(var Msg: TMessage);
virtual wm_First + wm_Command;
end;
{ Search Dialog Definition }
PSearchDialog = ^TSearchDialog;
TSearchDialog = object(TDialog)
constructor Init;
procedure SetupWindow; virtual;
procedure WMCommand(var Msg: TMessage);
virtual wm_First + wm_Command;
end;
{ Employee application object }
TEmployeeApp = object(TApplication)
procedure InitMainWindow; virtual;
end;
var
{ Application instance }
EmployeeApp: TEmployeeApp;
hdb: hDBIdb;
hCur: hDBICur;
function FillIndexCBox(Hw: HWND; ID: integer): integer;
var
i: integer;
Off: integer;
Index: Longint;
begin
for i := 1 to NumIndexes do
begin
Off := SendDlgItemMessage(Hw, ID, CB_ADDSTRING, 0,
LONGINT(PChar(@XIDXDesc[i].szTagName)));
SendDlgItemMessage(Hw, ID, CB_SETITEMDATA, Off, i);
end;
i := GetIndexNum(hCur);
{ Select that index from the combo box list. }
Off := SendDlgItemMessage(Hw, ID, CB_SELECTSTRING, word(-1),
Longint(PChar(@XIDXDesc[i].szTagName)));
Index := SendDlgItemMessage(Hw, ID, CB_GETITEMDATA, Off, 0);
{ Set the description text into the static text box based upon
the index's item data. }
FillIndexCBox := Index;
end;
procedure SetFieldLen(HW: HWND; ID, Index: Integer);
var
LimitLen: integer;
begin
case Index of
1: LimitLen := NameLen;
2: LimitLen := EmpIdLen;
3: LimitLen := DeptLen;
end; { case }
SendDlgItemMessage(HW, ID, EM_LIMITTEXT, LimitLen, 0);
end;
{ TOrderDialog }
constructor TOrderDialog.Init;
begin
inherited Init(@self, 'ORDERDLG');
end;
procedure TOrderDialog.SetupWindow;
var
Index: Longint;
begin
inherited SetupWindow;
Index := FillIndexCBox(HWindow, IDC_OrderIdxNames);
SetWindowText(GetDlgItem(HWindow, IDC_ORDERINFO), IDXDescriptions[Index]);
end;
procedure TOrderDialog.WMCommand(var Msg: TMessage);
var
Sel: integer;
Index: integer;
begin
case Msg.wParam of
IDC_OrderIdxNames:
if HiWord(Msg.LParam) = CBN_SELCHANGE then
begin
Sel := SendDlgItemMessage(HWindow, IDC_OrderIdxNames, CB_GETCURSEL, 0, 0);
Index := SendDlgItemMessage(HWindow, IDC_OrderIdxNames, CB_GETITEMDATA, Sel, 0);
{ Put the Index description in the static text box. }
SetWindowText(GetDlgItem(HWindow, IDC_OrderInfo), IDXDescriptions[Index]);
end;
id_Cancel:
EndDialog(HWindow, id_Cancel);
ID_OK:
begin
Sel := SendDlgItemMessage(HWindow, IDC_OrderIdxNames, CB_GETCURSEL, 0, 0);
Index := SendDlgItemMessage(HWindow, IDC_OrderIdxNames, CB_GETITEMDATA, Sel, 0);
SetIndex(hCur, Index, True);
EndDialog(HWindow, ID_OK);
end;
else
inherited WMCommand(Msg);
end; { case }
end;
{ TSearchDialog }
constructor TSearchDialog.Init;
begin
inherited Init(@self, 'SEARCHDLG');
end;
procedure TSearchDialog.SetupWindow;
var
Index: Longint;
begin
inherited SetupWindow;
Index := FillIndexCBox(HWindow, IDC_SearchIdxNames);
SetWindowText(GetDlgItem(HWindow, IDC_ORDERINFO), IDXDescriptions[Index]);
SetFieldLen(HWindow, IDE_SearchInfo, Index);
SendDlgItemMessage(HWindow, IDE_SearchInfo, EM_LIMITTEXT, 20, 0);
end;
procedure TSearchDialog.WMCommand(var Msg: TMessage);
var
Sel, Result: integer;
OldIndex, Index: integer;
SearchStr: array[0..MaxFieldSize] of char;
RetVal: Boolean;
begin
RetVal := false;
case Msg.wParam of
IDC_SearchIdxNames:
if HiWord(Msg.LParam) = CBN_SELCHANGE then
begin
Sel := SendDlgItemMessage(HWindow, IDC_SearchIdxNames, CB_GETCURSEL, 0, 0);
Index := SendDlgItemMessage(HWindow, IDC_SearchIdxNames, CB_GETITEMDATA, Sel, 0);
{ Put the Index description in the static text box. }
SetFieldLen(HWindow, IDE_SearchInfo, Index);
SendDlgItemMessage(HWindow, IDE_SearchInfo, WM_SETTEXT, 0, Longint(PChar('')));
end;
id_Cancel:
EndDialog(HWindow, id_Cancel);
ID_OK:
begin
{ Get the new index to search on. }
Sel := SendDlgItemMessage(HWindow, IDC_SearchIdxNames, CB_GETCURSEL, 0, 0);
Index := SendDlgItemMessage(HWindow, IDC_SearchIdxNames,CB_GETITEMDATA, Sel, 0);
OldIndex := GetIndexNum(hCur);
if OldIndex <> Index then
SetIndex(hCur, Index, true);
GetDlgItemText(HWindow, IDE_SearchInfo, SearchStr, MaxFieldSize);
{ Search based upon a keySEARCHGEQ condition and the search string. }
Result := Search(hCur, keySEARCHGEQ, @SearchStr);
case (Result) of
DBIERR_NONE:
begin
if AtEof(hCur) = True then
begin
BWCCMessageBox(HWindow, 'Could not find a match', 'Search Error',
MB_ICONINFORMATION or MB_OK);
if OldIndex <> Index then
SetIndex(hCur, OldIndex, true);
GoTop(hCur, true);
RetVal := False
end
else
RetVal := True;
end;
DBIERR_RECNOTFOUND:
begin
BWCCMessageBox(HWindow, 'Could not find a match', 'Search Error',
MB_ICONINFORMATION or MB_OK);
if OldIndex <> Index then
SetIndex(hCur, OldIndex, true);
GoTop(hCur, true);
RetVal := false;
end;
else
begin
BWCCMessageBox(HWindow, 'Could not find a match', 'Search Error',
MB_ICONINFORMATION or MB_OK);
if OldIndex <> Index then
SetIndex(hCur, OldIndex, true);
GoTop(hCur, true);
RetVal := false;
end;
end;
EndDialog(HWindow, word(RetVal));
end;
else
inherited WMCommand(Msg);
end; { case }
end;
{ TEmployee }
constructor TEmployee.Init;
begin
inherited Init(nil, 'EmployeeDLG');
if SetHandleCount(file_Handles) <> file_Handles then
begin
BWCCMessageBox(0, 'Not Enough File handles available', 'ERROR', mb_Ok);
PostQuitMessage(0);
end;
SetPrivateDir;
end;
procedure TEmployee.SetupWindow;
var
CurrentRec: PRecordType;
TblExist: boolean;
SearchRec: TSearchRec;
RetVal: DBIResult;
D: Double;
TableDir: PChar;
begin
inherited SetupWindow;
Mode := ModMode;
if DBInit <> DBIERR_NONE then
begin
BWCCMessageBox(0, 'DataBase could not be initialized', 'Message', mb_ok);
PostQuitMessage(0);
end;
GetMem(TableDir, dbiMAXPATHLEN + 1);
FindTablesDir(TableDir, 3);
StrCat(TableDir, '\');
StrCat(TableDir, TableName);
FindFirst(TableDir, faAnyFile, SearchRec);
if DosError <> 0 then
begin
if CreateTable <> DBIERR_NONE then
begin
BWCCMessageBox(0, 'Error Creating DataBase', 'Error!', mb_ok);
PostQuitMessage(0);
end
end;
FreeMem(TableDir, dbiMAXPATHLEN + 1);
{ Now a Table has been created or one already exists. Get the table's database
/ and cursor handles
}
if GetTable(hDb, hCur) = DBIERR_NONE then
begin
{ Set the table index to either: NameIndex, EmpIDIndex or DeptIndex }
SetIndex(hCur, NameIndex, false);
if (GetRecordCount(hCur) = 0) then
begin
TableEmpty := true;
AddInitialRecords(hCur);
end;
{ When we move to the top we are sitting on a crack before the
/ first record. If the table is not Empty go to the first record and
/ display the first Record.
}
TableEmpty := false;
GoTop(hCur, TRUE);
SendMessage(hWindow, wm_Display, 0, 0);
EnableWindow(GetDlgItem(HWindow, id_Cancel), false);
EnableWindow(GetDlgItem(HWindow, id_SaveRec), false);
ShowWindow(GetDlgItem(HWindow, id_Ok), sw_Hide);
end
else
BWCCMessageBox(0, 'Table could not be opened', 'Message', mb_ok);
end;
procedure TEmployee.ChangeMode(NewMode: integer);
begin
if NewMode = AddMode then
begin
ShowWindow(GetDlgItem(HWindow, id_FirstRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_PrevRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_LastRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_NextRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_NewRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_DelRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_SaveRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_UndoRec), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_Ok), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_Cancel), sw_Normal);
ShowWindow(GetDlgItem(HWindow, St_Names), sw_Normal);
ShowWindow(GetDlgItem(HWindow, St_Dates), sw_Normal);
Mode := AddMode;
end
else if NewMode = ModMode then
begin
ShowWindow(GetDlgItem(HWindow, id_FirstRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_PrevRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_LastRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_NextRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_NewRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_DelRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_SaveRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_UndoRec), sw_Normal);
ShowWindow(GetDlgItem(HWindow, id_Ok), sw_Hide);
ShowWindow(GetDlgItem(HWindow, id_Cancel), sw_Hide);
ShowWindow(GetDlgItem(HWindow, St_Names), sw_Hide);
ShowWindow(GetDlgItem(HWindow, St_Dates), sw_Hide);
Mode := ModMode;
end
end;
procedure TEmployee.ClearFields(Rec: PRecordType);
begin
with Rec^ do
begin
StrCopy(FName, '');
StrCopy(LName, '');
StrCopy(Address1, '');
StrCopy(Address2, '');
StrCopy(City, '');
StrCopy(State, '');
StrCopy(Zip, '');
StrCopy(HPhone, '');
StrCopy(WPhone, '');
EmpID := 0.0;
StrCopy(StartDate, '');
StrCopy(EndDate, '');
StrCopy(Department, '');
StrCopy(Comments, '');
end;
end;
procedure TEmployee.DisableCommand(commandID: Integer);
begin
EnableMenuItem(GetMenu(HWindow), CommandID, mf_ByCommand or mf_Grayed);
EnableWindow(GetDlgItem(HWindow, CommandId), false)
end;
procedure TEmployee.DisplayRecord(Rec: PRecordType);
var
S: array[0..10] of char; {string[10]; }
begin
SetDlgItemText(HWindow, IDE_FName, Rec^.FName);
SetDlgItemText(HWindow, IDE_LName, Rec^.LName);
SetDlgItemText(HWindow, IDE_Address1, Rec^.Address1);
SetDlgItemText(HWindow, IDE_Address2, Rec^.Address2);
SetDlgItemText(HWindow, IDE_City, Rec^.City);
SetDlgItemText(HWindow, IDE_State, Rec^.State);
SetDlgItemText(HWindow, IDE_Zip, Rec^.Zip);
SetDlgItemText(HWindow, IDE_HPhone, Rec^.HPhone);
SetDlgItemText(HWindow, IDE_WPhone, Rec^.WPhone);
SetDlgItemText(HWindow, IDE_StartDate, Rec^.StartDate);
SetDlgItemText(HWindow, IDE_EndDate, Rec^.EndDate);
str(trunc(Rec^.EmpId), S);
SetDlgItemText(HWindow, IDE_EmployeeID, S);
SetDlgItemText(HWindow, IDE_Department, Rec^.Department);
SetDlgItemText(HWindow, IDE_Comments, Rec^.Comments);
UpdateWindow(HWindow);
end;
procedure TEmployee.EnableCommand(commandID: Integer);
begin
EnableMenuItem(GetMenu(HWindow), CommandID, mf_ByCommand or mf_Enabled);
EnableWindow(GetDlgItem(HWindow, CommandId), true)
end;
procedure TEmployee.EnableControls;
begin
EnableWindow(GetDlgItem(HWindow, IDE_FName), true);
EnableWindow(GetDlgItem(HWindow, IDE_LName), true);
EnableWindow(GetDlgItem(HWindow, IDE_Address1), true);
EnableWindow(GetDlgItem(HWindow, IDE_Address2), true);
EnableWindow(GetDlgItem(HWindow, IDE_City), true);
EnableWindow(GetDlgItem(HWindow, IDE_State), true);
EnableWindow(GetDlgItem(HWindow, IDE_Zip), true);
EnableWindow(GetDlgItem(HWindow, IDE_HPhone), true);
EnableWindow(GetDlgItem(HWindow, IDE_WPhone), true);
EnableWindow(GetDlgItem(HWindow, IDE_EmployeeId), true);
EnableWindow(GetDlgItem(HWindow, IDE_StartDate), true);
EnableWindow(GetDlgItem(HWindow, IDE_EndDate), true);
EnableWindow(GetDlgItem(HWindow, IDE_Department), true);
EnableWindow(GetDlgItem(HWindow, IDE_Comments), true);
EnableWindow(GetDlgItem(HWindow, id_DelRec), true);
end;
Procedure TEmployee.DisableControls;
begin
EnableWindow(GetDlgItem(HWindow, IDE_FName), false);
EnableWindow(GetDlgItem(HWindow, IDE_LName), false);
EnableWindow(GetDlgItem(HWindow, IDE_Address1), false);
EnableWindow(GetDlgItem(HWindow, IDE_Address2), false);
EnableWindow(GetDlgItem(HWindow, IDE_City), false);
EnableWindow(GetDlgItem(HWindow, IDE_State), false);
EnableWindow(GetDlgItem(HWindow, IDE_Zip), false);
EnableWindow(GetDlgItem(HWindow, IDE_HPhone), false);
EnableWindow(GetDlgItem(HWindow, IDE_WPhone), false);
EnableWindow(GetDlgItem(HWindow, IDE_EmployeeId), false);
EnableWindow(GetDlgItem(HWindow, IDE_StartDate), false);
EnableWindow(GetDlgItem(HWindow, IDE_EndDate), false);
EnableWindow(GetDlgItem(HWindow, IDE_Department), false);
EnableWindow(GetDlgItem(HWindow, IDE_Comments), false);
EnableWindow(GetDlgItem(HWindow, id_DelRec), false);
end;
procedure TEmployee.GetRec(var Rec: TRecordType);
var
S: array[0..10] of char;
Code: integer;
begin
GetDlgItemText(HWindow, IDE_FName, Rec.FName, NameLen);
GetDlgItemText(HWindow, IDE_LName, Rec.LName, NameLen);
GetDlgItemText(HWindow, IDE_Address1, Rec.Address1, AddressLen);
GetDlgItemText(HWindow, IDE_Address2, Rec.Address2, AddressLen);
GetDlgItemText(HWindow, IDE_City, Rec.City, CityLen);
GetDlgItemText(HWindow, IDE_State, Rec.State, StateLen);
GetDlgItemText(HWindow, IDE_Zip, Rec.Zip, ZipLen);
GetDlgItemText(HWindow, IDE_HPhone, Rec.HPhone, PhoneLen);
GetDlgItemText(HWindow, IDE_WPhone, Rec.WPhone, PhoneLen);
GetDlgItemText(HWindow, IDE_StartDate, Rec.StartDate, DateLen);
GetDlgItemText(HWindow, IDE_EndDate, Rec.EndDate, DateLen);
GetDlgItemText(HWindow, IDE_EmployeeID, S, EmpIDLen);
val(S, Rec.EmpID, Code);
GetDlgItemText(HWindow, IDE_Department, Rec.Department, DeptLen);
GetDlgItemText(HWindow, IDE_Comments, Rec.Comments, CommentLen);
end;
function TEmployee.GetClassName: PChar;
begin
GetClassName := 'bordlg_employee';
end;
procedure TEmployee.GetWindowClass(var AWndClass: TWndClass);
begin
TDlgWindow.GetWindowClass(AWndClass);
AWndClass.hIcon := LoadIcon(HInstance, PChar(9999));
end;
function TEmployee.Verified: boolean;
function CheckDate(CkDate: Pchar): boolean;
var
DateNum: integer;
Month, Day, Year: array[0..3] of char;
code1, Code2, Code3: integer;
RetVal: boolean;
begin
RetVal := false;
if strComp(CkDate, '') = 0 then
RetVal := true
else begin
if (CkDate[2] = '-') and (CkDate[5] = '-') then
begin
strlcopy(Month, CkDate, 2);
strlcopy(Day, @CkDate[3], 2);
strlcopy(Year, @CkDate[6], 2);
end;
val(Month, DateNum, code1);
val(Day, DateNum, code2);
val(Year, DateNum, code3);
if (code1 = 0) and (code2 = 0) and (code3 = 0) then
RetVal := true;
end;
CheckDate := retval;
end;
var
Name: array[0..NameLen] of char;
FNameLen, LNameLen, Dt1Len, Dt2Len: integer;
Date1, Date2: array[0..DateLen] of char;
ValidDates: boolean;
begin
verified := false;
FNameLen := GetDlgItemText(HWindow, IDE_FName, Name, NameLen);
LNameLen := GetDlgItemText(HWindow, IDE_LName, Name, NameLen);
Dt1Len := GetDlgItemText(HWindow, IDE_StartDate, Date1, DateLen);
Dt2len := GetDlgItemText(HWindow, IDE_EndDate, Date2, DateLen);
ValidDates := ((Dt1Len = 8) and ((Dt2Len = 8) or (Dt2Len = 0)));
if (FNameLen > 0) and (ValidDates) then
if (CheckDate(Date2) and CheckDate(Date1)) then
verified := true
else
verified := false;
end;
procedure TEmployee.cmAbout(var Msg: TMessage);
var
PDlg: PDialog;
begin
PDlg := new(PDialog, init(@self, 'ABOUTDLG'));
PDlg^.Execute;
PDlg^.Done;
end;
procedure TEmployee.idExit(var Msg: TMessage);
begin
CloseDb(hdb, hCur);
CloseWindow;
end;
procedure TEmployee.idFirstRec(var Msg: TMessage);
begin
GoTop(hCur, True);
PostMessage(hWindow, wm_Display, 0, 0);
end;
procedure TEmployee.idLastRec(var Msg: TMessage);
begin
GoBottom(hCur, True);
PostMessage(hWindow, wm_Display, 0, 0);
end;
procedure TEmployee.idNextRec(var Msg: TMessage);
begin
if not AtEOF(HCur) then
begin
GetNextRec(hCur);
PostMessage(hWindow, wm_Display, 0, 0);
end;
end;
procedure TEmployee.idPrevRec(var Msg: TMessage);
begin
if not AtBOF(HCur) then
begin
GetPrevRec(HCur);
PostMessage(hWindow, wm_Display, 0, 0);
end;
end;
procedure TEmployee.idNewRec(var Msg: TMessage);
var
NewRec: PRecordType;
begin
EnableControls;
EnableMenuItem(GetMenu(HWindow), 0, mf_ByPosition or mf_Grayed);
EnableMenuItem(GetMenu(HWindow), 1, mf_ByPosition or mf_Grayed);
DrawMenuBar(HWindow);
new(NewRec);
ClearFields(NewRec);
ChangeMode(AddMode);
DisplayRecord(NewRec);
EnableWindow(GetDlgItem(HWindow, IDOK), false);
EnableWindow(GetDlgItem(HWindow, IDCancel), true);
Dispose(NewRec);
end;
procedure TEmployee.idDelRec(var Msg: TMessage);
var
Rec: PRecordType;
begin
if BWCCMessageBox(HWindow, 'Delete this record?', 'Message',
mb_YesNo or mb_IconQuestion) = idYes then
begin
DeleteRec(hCur);
if GetRecordCount(hCur) = 0 then
TableEmpty := true;
GoTop(hCur, not TableEmpty);
Postmessage(HWindow, wm_Display, 0, 0)
end;
end;
procedure TEmployee.WMCommand(var Msg: TMessage);
begin
case Msg.wParam of
IDE_FName,
IDE_LName,
IDE_Address1,
IDE_Address2,
IDE_City,
IDE_State,
IDE_Zip,
IDE_HPhone,
IDE_WPhone,
IDE_EmployeeId,
IDE_StartDate,
IDE_EndDate,
IDE_Department,
IDE_Comments:
begin
if (HIWORD(Msg.lParam) = EN_UPDATE) then
if Verified then
case Mode of
AddMode:
begin
EnableWindow(GetDlgItem(HWindow, idOK), true);
EnableWindow(GetDlgItem(HWindow, idCancel), true)
end;
ModMode:
begin
EnableWindow(GetDlgItem(HWindow, id_SaveRec), true);
EnableWindow(GetDlgItem(HWindow, id_UndoRec), true)
end;
end { case }
else
case Mode of
AddMode:
begin
EnableWindow(GetDlgItem(HWindow, idOK), false);
EnableWindow(GetDlgItem(HWindow, idCancel), true)
end;
ModMode:
begin
EnableWindow(GetDlgItem(HWindow, id_SaveRec), false);
EnableWindow(GetDlgItem(HWindow, id_UndoRec), true)
end;
end;
inherited WMCommand(Msg);
end
else
inherited WMCommand(Msg);
end;
end;
procedure TEmployee.OK(var Msg: TMessage);
var
CurrentRec: PRecordType;
begin
{ Get the data from the main Window and put it into the record structure. }
if TableEmpty then
begin
TableEmpty := false;
DisableControls;
end;
New(CurrentRec);
GetRec(CurrentRec^);
{ Insert the record into the table }
if AddRecord(hCur, CurrentRec, true) = DBIERR_NONE
then begin
ChangeMode(ModMode);
PostMessage(HWindow, wm_Display, 0, 0);
EnableMenuItem(GetMenu(HWindow), 0, mf_ByPosition or mf_Enabled);
EnableMenuItem(GetMenu(HWindow), 1, mf_ByPosition or mf_Enabled);
DrawMenuBar(HWindow);
end { then }
else
BWCCMessageBox(HWindow, 'Record could not be added', 'Error', mb_Ok);
dispose(CurrentRec);
end;
procedure TEmployee.IdOrder(var Msg: TMessage);
begin
if Application^.ExecDialog(New(POrderDialog, Init)) = ID_OK then
PostMessage(hWindow, wm_Display, 0, 0);
end;
procedure TEmployee.IdSearch(var Msg: TMessage);
begin
if Application^.ExecDialog(New(PSearchDialog, Init)) = ID_OK then
begin
GetNextRec(hCur);
PostMessage(hWindow, wm_Display, 0, 0);
end
else
begin
if AtBof(hCur) = True then
begin
PostMessage(hWindow, wm_Display, 0, 0);
end;
end;
end;
procedure TEmployee.IdSaveRec(var Msg: TMessage);
var
CurrentRec: PRecordType;
begin
{ Get the data from the main Window and put it into the record structure. }
New(CurrentRec);
GetRec(CurrentRec^);
{ Insert the record into the table }
AddRecord(hCur, CurrentRec, false);
PostMessage(HWindow, wm_Display, 0, 0);
dispose(CurrentRec);
EnableMenuItem(GetMenu(HWindow), 0, mf_ByPosition or mf_Enabled);
EnableMenuItem(GetMenu(HWindow), 1, mf_ByPosition or mf_Enabled);
DrawMenuBar(HWindow);
end;
procedure TEmployee.idUndoRec(var Msg: Tmessage);
var
l: longint;
begin
SendMessage(HWindow, wm_Display, 0, 0);
EnableWindow(GetDlgItem(HWindow, id_SaveRec), false);
EnableWindow(GetDlgItem(HWindow, id_UndoRec), false);
setfocus(GetDlgItem(HWindow, IDE_FName));
PostMessage(GetDlgItem(HWindow, IDE_FName), em_SetSel, 1, MakeLong(0, word(-1)));
end;
procedure TEmployee.Cancel(var Msg: TMessage);
var
CurrentRec: PRecordType;
begin
New(CurrentRec);
if TableEmpty then
DisableControls
else
GetData(hCur, CurrentRec);
ClearFields(CurrentRec);
DisplayRecord(CurrentRec);
dispose(CurrentRec);
ChangeMode(ModMode);
EnableMenuItem(GetMenu(HWindow), 0, mf_ByPosition or mf_Enabled);
EnableMenuItem(GetMenu(HWindow), 1, mf_ByPosition or mf_Enabled);
DrawMenuBar(HWindow);
end;
procedure TEmployee.WMClose(var Msg: TMessage);
begin
CloseDb(hdb, hCur);
CloseWindow;
end;
procedure TEmployee.wmDisplay(var Msg: TMessage);
var
Rec: PRecordType;
begin
if TableEmpty then
begin
DisableCommand(id_PrevRec);
DisableCommand(id_FirstRec);
DisableCommand(id_NextRec);
DisableCommand(id_LastRec);
DisableControls;
Rec := new(PRecordType);
ClearFields(Rec);
DisplayRecord(Rec);
dispose(Rec);
end
else
begin
EnableControls;
Rec := new(PRecordType);
GetData(hCur, Rec);
DisplayRecord(Rec);
{ Only one record exists in table }
if (AtEOF(HCur) and AtBOF(hCur))then
begin
DisableCommand(id_PrevRec);
DisableCommand(id_FirstRec);
DisableCommand(id_NextRec);
DisableCommand(id_LastRec);
DisableCommand(id_SaveRec);
end
else { At beginning of file with more than one record. }
begin
if (AtBOF(HCur) and not AtEOF(hCur))then
begin
DisableCommand(id_PrevRec);
DisableCommand(id_FirstRec)
end
else
begin
EnableCommand(id_PrevRec);
EnableCommand(id_FirstRec)
end;
{ At end of file with more than one record }
if (AtEOF(HCur) and not AtBOF(hCur))then
begin
DisableCommand(id_NextRec);
DisableCommand(id_LastRec);
end
else
begin
EnableCommand(id_NextRec);
EnableCommand(id_LastRec);
end;
end;
{ Disable the buttons and menu options for Undo and Commit and set focus to
/ first name}
DisableCommand(id_SaveRec);
DisableCommand(id_UndoRec);
Dispose(Rec);
end { else }
end;
procedure TEmployeeApp.InitMainWindow;
begin
MainWindow := New(PEmployee, Init);
end;
begin
EmployeeApp.Init(AppName);
EmployeeApp.Run;
EmployeeApp.Done;
end.
Reference in New Issue View Git Blame Copy Permalink