CydandClaude Fable 5
63312e07f9
- 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>
1873 lines
69 KiB
ObjectPascal
1873 lines
69 KiB
ObjectPascal
{ sniptool.pas }
|
|
unit SnipTool;
|
|
{$N+}
|
|
interface
|
|
|
|
{$IfDef VER80}
|
|
uses SnipData, SysUtils, WinProcs, WinTypes, WinCrt, DbiTypes,
|
|
DbiProcs, DbiErrs;
|
|
{$Else}
|
|
uses WinProcs, WinTypes, WinDos, WinCrt, Strings,
|
|
DbiProcs, DbiTypes, DbiErrs, SnipData;
|
|
{$EndIf}
|
|
|
|
const
|
|
MAXLEN = 50;
|
|
szFileName = 'SNIPIT.OUT';
|
|
|
|
type
|
|
pPChar = ^PChar;
|
|
|
|
|
|
function IntToStr(i: integer): String;
|
|
function RightPad(szDest, szSource: PChar; iTotalSize: Integer): PChar;
|
|
function ChkRslt (rslt, exp: DBIResult; pMsg: PChar ): DBIResult;
|
|
function InitAndConnect (var phDb: hDBIDb): DBIResult;
|
|
function CloseDbAndExit (var phDb: hDBIDb): DBIResult;
|
|
function FillTable (hDb: hDBIDb; szTblName, szTblType: PChar; NumRecs: Integer): DBIResult;
|
|
function CreateAndFillTable (hDb: hDBIDb; pTblDesc: pCRTblDesc; NumRecs: Integer;
|
|
var phCur: hDBICur): DBIResult;
|
|
function DisplayInMemoryTable (hCur: hDBICur; uDisplayNRecs: longint): DBIResult;
|
|
function DisplayTable (hCur: hDBICur; uDisplayNRecs: LongInt): DBIResult;
|
|
function PutFieldSample (hCur: hDBICur; pRecBuf: pBYTE; FldNum: Word;
|
|
pfldDesc: pFLDDesc): DBIResult;
|
|
function MakeFullPath (szDirectory: PChar): DBIResult;
|
|
function MakeFullTblPath (pszDirectory :PChar;
|
|
pszRelativeDirectory: PChar) :DBIResult;
|
|
function DisplayNextRecord(hCur: hDBICur): DBIResult;
|
|
function DisplayCurrentRecord (hCur: hDBICur): DBIResult;
|
|
procedure Screen (Format: String);
|
|
procedure InitOutput;
|
|
procedure CloseOutput;
|
|
|
|
implementation
|
|
|
|
{==============================================================
|
|
Function:
|
|
IntToStr(i);
|
|
Input: i - Integer
|
|
|
|
Return: Converted Pascal String
|
|
|
|
Description:
|
|
This converts an Integer to a Pascal String
|
|
=============================================================== }
|
|
function IntToStr(i: integer): String;
|
|
var
|
|
s: String;
|
|
begin
|
|
Str(i,s);
|
|
IntToStr := s;
|
|
end;
|
|
|
|
{==============================================================
|
|
function:
|
|
RightPad(szDest, szSource, iTotalSize);
|
|
|
|
Input: szDest - PChar: Destination String
|
|
szSource - PChar: Source String
|
|
iTotalSize - Integer: The TotalSize the Destination
|
|
String should be.
|
|
Return: szDest - PChar: Destination String
|
|
|
|
Description:
|
|
This converts a string's length to the requested length
|
|
by filling balnk spaces to the right.
|
|
=============================================================== }
|
|
function RightPad(szDest, szSource: PChar; iTotalSize: Integer): PChar;
|
|
var
|
|
Count: Integer;
|
|
begin
|
|
if not Assigned(szSource) then
|
|
StrCopy(szDest,' ')
|
|
else
|
|
begin
|
|
StrCopy(szDest, szSource);
|
|
for Count := 1 to (iTotalSize-StrLen(szSource)) do
|
|
StrCat(szDest,' ');
|
|
end;
|
|
RightPad := szDest;
|
|
end;
|
|
|
|
{===============================================================
|
|
Procedure:
|
|
Screen(Format, argptr);
|
|
|
|
Input: Format - A string that represents the format that
|
|
the function vsprintf() uses.
|
|
argptr - A varied number of input parameters (based
|
|
on the needs of the format string).
|
|
|
|
Return: None.
|
|
|
|
Description:
|
|
This will build, and echo, a message.
|
|
=============================================================== }
|
|
procedure Screen (Format: String);
|
|
var
|
|
i: integer;
|
|
|
|
begin
|
|
WriteLn(Format);
|
|
end;
|
|
|
|
|
|
{===============================================================
|
|
Procedure: InitOutput;
|
|
Input: None.
|
|
Return: None.
|
|
Description:
|
|
Assigns the Output to a text file. This routine also
|
|
initializes szTblDirectory and szPrivDirectory.
|
|
=============================================================== }
|
|
procedure InitOutput;
|
|
begin
|
|
|
|
GetMem (szTblDirectory, DBIMAXPATHLEN);
|
|
GetMem (szPrivDirectory, DBIMAXPATHLEN);
|
|
|
|
{ Get the directory which contains the tables. }
|
|
GetPrivateProfileString('PASCAL', 'TblDir',
|
|
'..\TABLES',
|
|
szDefTblDirectory,
|
|
sizeof(szDefTblDirectory),
|
|
'bde.ini');
|
|
|
|
{ Create a fully qualified path for the table directory. }
|
|
MakeFullTblPath (szTblDirectory, szDefTblDirectory);
|
|
|
|
{ Get the Private directory. }
|
|
GetPrivateProfileString('PASCAL', 'PrivateDir',
|
|
'.',
|
|
szDefTblDirectory,
|
|
sizeof(szDefTblDirectory),
|
|
'bde.ini');
|
|
|
|
{ Create a fully qualified path for the private directory. }
|
|
MakeFullTblPath (szPrivDirectory, szDefTblDirectory);
|
|
|
|
Screen('*** Redirecting output to '+szFileName+'...');
|
|
Assign(Output, szFileName);
|
|
Rewrite(Output);
|
|
end;
|
|
|
|
|
|
{===============================================================
|
|
Procedure: CloseOutput;
|
|
Input: None.
|
|
Return: None.
|
|
Description:
|
|
Assigns the Output back to Crt.
|
|
=============================================================== }
|
|
procedure CloseOutput;
|
|
begin
|
|
Close(Output);
|
|
AssignCrt(Output);
|
|
Rewrite(Output);
|
|
end;
|
|
|
|
|
|
{==============================================================
|
|
Function:
|
|
ChkRslt(rslt, pMsg);
|
|
Input: rslt - Return code from IDAPI
|
|
pMsg - Null terminated message.
|
|
|
|
Return: IDAPI return code passed in
|
|
|
|
Description:
|
|
This will echo an error message if the expected
|
|
result does not equal the actual result. The output will be
|
|
echoed to the screen.
|
|
=============================================================== }
|
|
function ChkRslt (rslt, exp: DBIResult; pMsg: PChar ): DBIResult;
|
|
var
|
|
dbi_status: DBIMSG;
|
|
|
|
begin
|
|
{ Echo only if actual result doesn't equal expected result }
|
|
if (rslt <> exp) then
|
|
begin
|
|
DbiGetErrorString(rslt, dbi_status);
|
|
Screen(' '+StrPas(pMsg)+' category: ['+IntToStr(ErrCat(rslt))+'] code: ['+
|
|
IntToStr(ErrCode(rslt))+'] message: '+StrPas(dbi_status));
|
|
end;
|
|
ChkRslt := rslt;
|
|
end;
|
|
|
|
{===============================================================
|
|
Function:
|
|
InitAndConnect(phDb);
|
|
|
|
Input: phDb - Pointer to the database handle
|
|
|
|
Return: IDAPI return code after DbiInit() and DbiOpenDatabase().
|
|
|
|
Description:
|
|
Initialize IDAPI & connect to a Standard
|
|
database (non-SQL).
|
|
================================================================ }
|
|
function InitAndConnect (var phDb: hDBIDb): DBIResult;
|
|
var
|
|
rslt: DBIResult;
|
|
|
|
begin
|
|
|
|
{ Initialize IDAPI with a NULL environment structure }
|
|
rslt := ChkRslt(DbiInit(nil), DBIERR_NONE,' Error - Init');
|
|
if (rslt = DBIERR_NONE) then
|
|
begin
|
|
|
|
ChkRslt(DbiDebugLayerOptions(DEBUGON or OUTPUTTOFILE,
|
|
'SNIPIT.DBG'), DBIERR_NONE,
|
|
' Error - DebugLayerOptions.');
|
|
{ IDAPI initialized. Now open a Standard database (used to access
|
|
Paradox and dBASE tables), by using a NULL database type. }
|
|
rslt := ChkRslt(DbiOpenDatabase(nil, nil, dbiREADWRITE,
|
|
dbiOPENSHARED, nil, 0, nil, nil,
|
|
phDb),
|
|
DBIERR_NONE, ' Error - OpenDatabase.');
|
|
|
|
{ Exit IDAPI if connect did not work }
|
|
if (rslt <> DBIERR_NONE) then
|
|
ChkRslt(DbiExit, DBIERR_NONE, ' Error - Exit.');
|
|
|
|
{ Assign the Output to a text file and initialize
|
|
szTblDirectory, szPrivDirectory directories. }
|
|
InitOutput;
|
|
|
|
rslt := ChkRslt( DbiSetPrivateDir(szPrivDirectory),
|
|
DBIERR_NONE, ' SetPrivateDir.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
CloseOutput;
|
|
ChkRslt(DbiExit, DBIERR_NONE, ' Error - Exit.');
|
|
end;
|
|
|
|
end;
|
|
InitAndConnect := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
FormatDate (DATE Date, PChar szDate)
|
|
|
|
Input: DATE - Date which needs to be formatted
|
|
szDate - String to contain the formatted date
|
|
|
|
Return: Result returned from DbiDateDecode().
|
|
|
|
Description:
|
|
This function is used to format date fields according to the
|
|
settings in the IDAPI.CFG file.
|
|
===================================================================== }
|
|
function FormatDate (dDate: DbiTypes.DATE; szDate: PChar): DBIResult;
|
|
var
|
|
rslt: DBIResult; { Return Value from IDAPI }
|
|
dfmtDate: FMTDate; { Date Format }
|
|
uDay: Word; { Day portion of date }
|
|
uMonth: Word; { Month portion of date }
|
|
iYear: Integer; { Year portion of date }
|
|
sDay, sMonth, sYear: String;
|
|
begin
|
|
{ Get the formatting of the Date }
|
|
ChkRslt(DbiGetDateFormat(dfmtDate),
|
|
DBIERR_NONE, ' GetDateFormat.');
|
|
|
|
{ Decode the date }
|
|
rslt := ChkRslt(DbiDateDecode(dDate, uMonth, uDay, iYear),DBIERR_NONE,
|
|
' Error - DateDecode.');
|
|
|
|
{ Determine if date should be displayed year based }
|
|
if ((not (dfmtDate.bFourDigitYear)) and
|
|
(dfmtDate.bYearBiased) ) then
|
|
iYear := iYear+1900;
|
|
|
|
if (not (dfmtDate.bFourDigitYear )) then
|
|
begin
|
|
iYear := iYear - 1900;
|
|
Str(iYear:2, sYear);
|
|
end
|
|
else
|
|
Str(iYear:4, sYear);
|
|
|
|
{ Make certain the seperator is not the
|
|
escape character. }
|
|
if (StrComp(dfmtDate.szDateSeparator, '\') <> 0) then
|
|
StrCopy(dfmtDate.szDateSeparator, '/');
|
|
|
|
Str(uDay:2, sDay);
|
|
Str(uMonth:2, sMonth);
|
|
{ Format the date }
|
|
case BYTE(dfmtDate.iDateMode) of
|
|
{ MM/DD/YY - Month, Day, Year }
|
|
0:
|
|
StrPCopy(szDate,
|
|
sMonth+StrPas(dfmtDate.szDateSeparator)+
|
|
sDay+StrPas(dfmtDate.szDateSeparator)+
|
|
sYear);
|
|
{ DD/MM/YY - Day, Month, Year }
|
|
1:
|
|
StrPCopy(szDate,
|
|
sDay+StrPas(dfmtDate.szDateSeparator)+
|
|
sMonth+StrPas(dfmtDate.szDateSeparator)+
|
|
sYear);
|
|
{ YY/MM/DD - Year, Month, Day }
|
|
2:
|
|
StrPCopy(szDate,
|
|
sYear+StrPas(dfmtDate.szDateSeparator)+
|
|
sMonth+StrPas(dfmtDate.szDateSeparator)+
|
|
sDay);
|
|
end;
|
|
FormatDate := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
FormatTime (TIME Time, PChar szTime)
|
|
|
|
Input: TIME - Time which needs to be formatted
|
|
szTime - String to contain the formatted time
|
|
|
|
Return: Result returned from DbiTimeDecode().
|
|
|
|
Description:
|
|
This function is used to format time fields according to
|
|
the settings in the IDAPI.CFG file.
|
|
===================================================================== }
|
|
function FormatTime (tTime: DbiTypes.TIME; szTime: PChar): DBIResult;
|
|
var
|
|
rslt: DBIResult; { Return value from IDAPI functions }
|
|
timeFmt: FMTTime; { Time format }
|
|
uHour: Word; { Hour portion of the time }
|
|
uMinute: Word; { Minute portion of the time }
|
|
uMilSec: Word; { Second portion (in ms) of the time }
|
|
uIsAm: Word; { Is Time AM? }
|
|
szTemp: array[0..10] of CHAR; { Temp buffer, used for AM, PM string }
|
|
sHour, sMinute, sSec, sMilSec: String;
|
|
|
|
begin
|
|
{ Get the formatting of the Time }
|
|
ChkRslt(DbiGetTimeFormat(timeFmt),
|
|
DBIERR_NONE, ' GetTimeFormat.');
|
|
|
|
{ Decode the time }
|
|
rslt := ChkRslt(DbiTimeDecode(tTime, uHour, uMinute, uMilSec),
|
|
DBIERR_NONE, ' Error - TimeDecode.');
|
|
|
|
{ Make certain the seperator is not the
|
|
escape character. }
|
|
if (timeFmt.cTimeSeparator = '\') then
|
|
timeFmt.cTimeSeparator := '/';
|
|
|
|
{ Check if time should be displayed in 12 or 24 hour format }
|
|
if (timeFmt.bTwelveHour) then
|
|
begin
|
|
{ Temporary variable used to determine if the time is AM or PM }
|
|
uIsAm := uHour;
|
|
uHour := uHour mod 12;
|
|
if (uHour = 0) then
|
|
uHour := 12;
|
|
{ If AM, set uIsAm to TRUE, else set uIsAm to 0 }
|
|
if (uIsAm = uHour) then
|
|
uIsAm := 1
|
|
else
|
|
uIsAm := 0;
|
|
end;
|
|
Str(uHour:2,sHour);
|
|
Str(uMinute:2, sMinute);
|
|
Str((round (uMilsec/1000)):2, sSec);
|
|
Str((round (uMilSec mod 1000)):2, sMilsec);
|
|
{ Format the hour and minute of the time }
|
|
|
|
StrPCopy(szTime, sHour+timeFmt.cTimeSeparator+sMinute);
|
|
|
|
{ Determine if seconds are to be displayed }
|
|
if (timeFmt.bSeconds) then
|
|
begin
|
|
StrPCopy(szTemp, timeFmt.cTimeSeparator+sSec);
|
|
StrCat(szTime, szTemp);
|
|
{ Determine if milliseconds are to be displayed }
|
|
if (timeFmt.bMilSeconds) then
|
|
begin
|
|
StrPCopy(szTemp, timeFmt.cTimeSeparator+sMilsec);
|
|
StrCat(szTime, szTemp);
|
|
end;
|
|
end;
|
|
|
|
{ Add a string to the time if the time is 12-hour }
|
|
if (timeFmt.bTwelveHour) then
|
|
begin
|
|
{ Add a space to the format }
|
|
StrCat(szTime, ' ');
|
|
{ If AM }
|
|
if (uIsAm = 1) then
|
|
{ Copy the AM string }
|
|
StrCat(szTime, timeFmt.szAmString)
|
|
else { otherwise it's PM }
|
|
{ Copy the PM string }
|
|
StrCat(szTime, timeFmt.szPmString);
|
|
end;
|
|
|
|
FormatTime := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
FormatTimeStamp (TIMESTAMP tStamp, PChar szTime)
|
|
|
|
Input: TIME - Time which needs to be formatted
|
|
szTime - String to contain the formatted time
|
|
|
|
Return: Result returned from DbiTimeStampDecode().
|
|
|
|
Description:
|
|
This function is used to format TimeStamp fields according
|
|
to the settings in the IDAPI.CFG file. It calls the
|
|
FormatDate and FormatTime functions which are defined
|
|
above.
|
|
===================================================================== }
|
|
function FormatTimeStamp (tStamp: TIMESTAMP; szTimeStamp: PChar): DBIResult;
|
|
var
|
|
rslt: DBIResult; { Return value from IDAPI functions }
|
|
tTime: DbiTypes.TIME; { Time portion of the TimeStamp }
|
|
dDate: DbiTypes.DATE; { Date portion of the TimeStamp }
|
|
szDate: PChar; { Date string }
|
|
szTime: pChar; { Time String }
|
|
begin
|
|
{ Get the date and time components }
|
|
rslt := ChkRslt(DbiTimeStampDecode(tStamp, dDate, tTime),
|
|
DBIERR_NONE, ' Error - TimeStampDecode');
|
|
GetMem(szDate, 16 * sizeof(CHAR));
|
|
GetMem(szTime, 21 * sizeof(CHAR));
|
|
{ Get the Date format }
|
|
FormatDate(dDate, szDate);
|
|
{ Get the Time format }
|
|
FormatTime(tTime, szTime);
|
|
{ Format the TimeStamp }
|
|
szTime := StrCat(szTime,', ');
|
|
StrCopy(szTimeStamp, Strcat(szTime,szDate));
|
|
FormatTimeStamp := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
GetFields(hCur, pFldDescs, pRecBuf, pszField, uDefLength)
|
|
|
|
Input: hCur - Handle to the Cursor
|
|
pFldDescs - Field Descriptor
|
|
pRecBuf - Record buffer - contains the record from
|
|
which the field values are to be retrieved.
|
|
pszField - Fields in the table
|
|
uDefLength - Default length of a field
|
|
|
|
Return: Success of the opperation.
|
|
|
|
Description:
|
|
This function is used to extract all field values from
|
|
a record and place them into an array of Strings.
|
|
===================================================================== }
|
|
|
|
function GetFields (hCur: hDBICur; pFldDescs: pFLDDesc; pRecBuf: Pointer;
|
|
pszField: pPCHAR; uDefLength: Word): DBIResult;
|
|
var
|
|
rslt: DBIResult; { Return value from IDAPI functions }
|
|
TblProps: CURProps; { Properties of the table }
|
|
uFldNum: Word; { Loop Counter - used to determine the
|
|
current field. }
|
|
Work: String;
|
|
szTemp: array[0..MAXLEN] of CHAR; { Temporary variable for reading data }
|
|
szTempAsFloat: Double absolute szTemp; { Reading the Temporary
|
|
variable as Float}
|
|
szTempAsLongInt: LongInt absolute szTemp; { Reading the Temporary
|
|
variable as LongInt}
|
|
szTempAsInt: Integer absolute szTemp; { Reading the Temporary
|
|
variable as Integer}
|
|
szTempAsShortInt: ShortInt absolute szTemp; { Reading the Temporary
|
|
variable as ShortInt}
|
|
fmBCD: fmtBCD; { Variable to read BCD value }
|
|
ulBlobSize: LongInt; { Variable to read Longint Values }
|
|
lfFloat: Double; { Variable to read Double Values }
|
|
Code: Integer; { Used in Val Function }
|
|
bIsBlank: BOOL; { Check if the field is blank }
|
|
|
|
begin
|
|
rslt := ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
|
|
' Error - GetCursorProps.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
GetFields := rslt;
|
|
exit;
|
|
end;
|
|
|
|
{ Get the field values from the record. Gets each field from
|
|
the table, placing the results in the pszField variable }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
case (pFldDescs^.iFldType) of
|
|
fldBYTES,
|
|
fldZSTRING:
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
pszField^, bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
fldFLOAT:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp), bIsBlank),
|
|
DBIERR_NONE, ' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
if (pFldDescs^.iSubType = fldstMONEY) then
|
|
begin
|
|
Str(szTempAsFloat:0:2, Work);
|
|
StrPCopy(pszField^,'$'+Work);
|
|
end
|
|
else
|
|
begin
|
|
Str(szTempAsFloat:0:1, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldBCD:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@fmBCD),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
begin
|
|
ChkRslt(DbiBcdToFloat(fmBCD,lfFloat),
|
|
DBIERR_NONE, ' BcdToFloat.');
|
|
Str(lfFloat:0:1, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldDATE:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@ulBlobSize),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
FormatDate(ulBlobSize, pszField^);
|
|
end;
|
|
fldTIME:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@ulBlobSize),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
FormatTime(ulBlobSize, pszField^);
|
|
end;
|
|
fldTIMESTAMP:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@lfFloat),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
FormatTimeStamp(lfFloat, pszField^);
|
|
end;
|
|
fldINT16:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
begin
|
|
Str(szTempAsInt, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldUINT16:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
begin
|
|
Str(szTempAsInt, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldINT32:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
begin
|
|
Str(szTempAsLongInt, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldUINT32:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
begin
|
|
Str(szTempAsLongInt, Work);
|
|
StrPCopy(pszField^, Work);
|
|
end;
|
|
end;
|
|
fldBOOL:
|
|
begin
|
|
ChkRslt(DbiGetField(hCur, uFldNum, pRecBuf,
|
|
(@szTemp),
|
|
bIsBlank), DBIERR_NONE,
|
|
' Error - GetField.');
|
|
if (not bIsBlank) then
|
|
if (szTempAsShortInt = 0) then
|
|
StrCopy(pszField^, 'No')
|
|
else
|
|
StrCopy(pszField^, 'Yes');
|
|
end;
|
|
fldBLOB:
|
|
{ Display the first uDefLength characters of
|
|
Memo BLOB fields. }
|
|
if (pFldDescs^.iSubType = fldstMEMO) then
|
|
begin
|
|
ChkRslt(DbiOpenBlob(hCur, pRecBuf,
|
|
uFldNum, dbiREADONLY),
|
|
DBIERR_NONE, ' Error - OpenBlob.');
|
|
|
|
{Determine the size of the BLOB }
|
|
ChkRslt(DbiGetBlobSize(hCur, pRecBuf,
|
|
uFldNum, ulBlobSize),
|
|
DBIERR_NONE, ' Error - GetBlobSize.');
|
|
|
|
if (ulBlobSize > (uDefLength-2)) then
|
|
ulBlobSize := uDefLength - 2;
|
|
|
|
{ Get the BLOB from the table }
|
|
ChkRslt(DbiGetBlob(hCur, pRecBuf,
|
|
uFldNum, 0,
|
|
ulBlobSize,
|
|
pszField^,
|
|
ulBlobSize),
|
|
DBIERR_NONE, ' Error - GetBlob.');
|
|
|
|
{ Add the nil terminator to the string. }
|
|
pszField^[Integer(ulBlobSize)] := #0;
|
|
|
|
{ Free the blob from memory }
|
|
ChkRslt(DbiFreeBlob(hCur, pRecBuf,
|
|
uFldNum),
|
|
DBIERR_NONE, ' Error - FreeBlob.');
|
|
end
|
|
else
|
|
StrCopy(pszField^, 'Can''t Display');
|
|
else
|
|
StrCopy(pszField^, 'Can''t Display');
|
|
end; {end of case}
|
|
{ Initialize the string in case the field was blank }
|
|
if (bIsBlank) then
|
|
begin
|
|
StrCopy(pszField^, '');
|
|
bIsBlank := FALSE;
|
|
end;
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
GetFields := DBIERR_NONE;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
SetupFields(TblProps, pFldDescs, pszField, uDefLength)
|
|
|
|
Input: TblProps - Properties of the Table
|
|
pFldDescs - Field Descriptor
|
|
pszField - Fields in the table
|
|
uDefLength - Default length of a field
|
|
|
|
Return: DBIERR_NONE (success)
|
|
|
|
Description:
|
|
This function sets up the formatting of the fields.
|
|
===================================================================== }
|
|
function SetupFields (TblProps: CURProps; pFldDescs: pFLDDesc;
|
|
pszField: pPChar; uDefLength: Word): DBIResult;
|
|
var
|
|
uFldNum: Word; { Loop variable }
|
|
|
|
begin
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
{ Allocate enough space to contain the data in each field }
|
|
case (pFldDescs^.iFldType) of
|
|
fldBYTES,
|
|
fldZSTRING:
|
|
begin
|
|
GetMem(pszField^, pFldDescs^.iLen * sizeof(CHAR));
|
|
if (MAXLEN - 4 < pFldDescs^.iLen) then
|
|
begin
|
|
pFldDescs^.iUnits1 := MAXLEN-4;
|
|
pFldDescs^.iLen := MAXLEN-3;
|
|
end;
|
|
{ Adjust if the field is smaller than it's description }
|
|
if (pFldDescs^.iLen < StrLen(pFldDescs^.szName)) then
|
|
begin
|
|
pFldDescs^.iUnits1 := StrLen(pFldDescs^.szName);
|
|
pFldDescs^.iLen := pFldDescs^.iUnits1 - 1;
|
|
end;
|
|
end;
|
|
fldFLOAT,
|
|
fldDATE,
|
|
fldINT16,
|
|
fldUINT16,
|
|
fldINT32,
|
|
fldUINT32,
|
|
fldBOOL,
|
|
fldBLOB,
|
|
fldBCD:
|
|
begin
|
|
GetMem(pszField^, uDefLength * sizeof(CHAR));
|
|
{ Set the Width of the field as it will be displayed }
|
|
pFldDescs^.iUnits1 := uDefLength-1;
|
|
pFldDescs^.iLen := uDefLength;
|
|
{ Adjust if the field is smaller than it's description }
|
|
if (pFldDescs^.iLen < StrLen(pFldDescs^.szName)) then
|
|
begin
|
|
pFldDescs^.iUnits1 := StrLen(pFldDescs^.szName);
|
|
pFldDescs^.iLen := pFldDescs^.iUnits1 - 1;
|
|
end;
|
|
end;
|
|
fldTIMESTAMP:
|
|
begin
|
|
GetMem(pszField^, 36 * sizeof(CHAR));
|
|
{ Set the Width of the field as it will be displayed }
|
|
pFldDescs^.iUnits1 := 36;
|
|
pFldDescs^.iLen := 35;
|
|
{ Adjust if the field is smaller than it's description }
|
|
if (pFldDescs^.iLen < StrLen(pFldDescs^.szName)) then
|
|
begin
|
|
pFldDescs^.iUnits1 := StrLen(pFldDescs^.szName);
|
|
pFldDescs^.iLen := pFldDescs^.iUnits1 - 1;
|
|
end;
|
|
end;
|
|
fldTIME:
|
|
begin
|
|
GetMem(pszField^, 20 * sizeof(CHAR));
|
|
{ Set the Width of the field as it will be displayed }
|
|
pFldDescs^.iUnits1 := 20;
|
|
pFldDescs^.iLen := 19;
|
|
{ Adjust if the field is smaller than it's description }
|
|
if (pFldDescs^.iLen < StrLen(pFldDescs^.szName)) then
|
|
begin
|
|
pFldDescs^.iUnits1 := StrLen(pFldDescs^.szName);
|
|
pFldDescs^.iLen := pFldDescs^.iUnits1 - 1;
|
|
end;
|
|
end;
|
|
else
|
|
begin
|
|
{ This field size will hold the 'Not Supported'
|
|
message }
|
|
GetMem(pszField^, uDefLength * sizeof(CHAR));
|
|
{ Set the width of the field as it will be displayed }
|
|
pFldDescs^.iUnits1 := uDefLength;
|
|
end;
|
|
end;{end of case}
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
SetUpFields := DBIERR_NONE;
|
|
end;
|
|
|
|
{===============================================================
|
|
Function:
|
|
CloseDbAndExit(phDb);
|
|
|
|
Input: phDb - Pointer to the database handle
|
|
|
|
Return: IDAPI return code after DbiCloseDatabase() and DbiExit().
|
|
|
|
Description:
|
|
Close the supplied database & exit IDAPI.
|
|
================================================================ }
|
|
function CloseDbAndExit (var phDb: hDBIDb): DBIResult;
|
|
var
|
|
rslt: DBIResult;
|
|
|
|
begin
|
|
Close(Output);
|
|
AssignCrt(Output);
|
|
Rewrite(Output);
|
|
|
|
{ Close the supplied database }
|
|
rslt := ChkRslt(DbiCloseDatabase(phDb), DBIERR_NONE,
|
|
' Error - CloseDatabase');
|
|
if (rslt = DBIERR_NONE) then
|
|
begin
|
|
{ Uninitialize IDAPI }
|
|
rslt := DbiDebugLayerOptions(0, nil);
|
|
rslt := ChkRslt(DbiExit, DBIERR_NONE, ' Error - Exit.');
|
|
end;
|
|
CloseDbAndExit := rslt;
|
|
end;
|
|
|
|
|
|
{=====================================================================
|
|
Function:
|
|
FillTable(hDb, szTblName, szTblType, NumRecs);
|
|
|
|
Input: hDb - The database handle
|
|
szTblName - Name of the table to fill
|
|
szTblTyps - Type of the table to fill
|
|
NumRecs - The number of records to insert
|
|
|
|
Return: DBIResult - success?
|
|
|
|
Description:
|
|
This function add the specified number of records to
|
|
the table containing random data.
|
|
===================================================================== }
|
|
function FillTable (hDb: hDBIDb; szTblName, szTblType: PChar;
|
|
NumRecs: Integer): DBIResult;
|
|
var
|
|
rslt: DBIResult; { Return value from IDAPI functions }
|
|
fRecCount: Integer; { Loop variable = count of records }
|
|
FldCntr: Word; { Field counter }
|
|
fldDes: FLDDesc; { Field Descriptor }
|
|
TblProps: CURProps; { Table descriptor }
|
|
hCur: hDBICur; { Handle to the table }
|
|
hFldList: hDBICur; { Handle to the field list table }
|
|
const
|
|
pRecBuf: pBYTE = nil; {Pointer to the record buffer }
|
|
|
|
begin
|
|
Randomize;
|
|
{ Echo the message that the records are being inserted }
|
|
Screen(' Inserting '+IntToStr(NumRecs)+' records into the table...');
|
|
|
|
{ Open the table }
|
|
rslt := ChkRslt(DbiOpenTable(hDb, szTblName, szTblType, nil,
|
|
nil, 0, dbiREADWRITE,
|
|
dbiOPENSHARED, xltFIELD, FALSE,
|
|
nil, hCur), DBIERR_NONE, ' Error - OpenTable.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
FillTable := rslt;
|
|
exit;
|
|
end;
|
|
|
|
{ Create an in-memory table that contains a list of fields. Note
|
|
that logical (i.e. IDAPI types), are being requested instead of
|
|
driver types. }
|
|
rslt := ChkRslt(DbiOpenFieldList(hDb, szTblName, szTblType,
|
|
FALSE, hFldList),
|
|
DBIERR_NONE, ' Error - OpenFieldList.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
|
|
' Error - CloseCursor.');
|
|
FillTable := rslt;
|
|
exit;
|
|
end;
|
|
|
|
{ Append the records if the list & table are available }
|
|
if ((hCur <> nil) and (hFldList <> nil)) then
|
|
begin
|
|
{ Allocate a record buffer }
|
|
ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
|
|
' Error - GetCursorProps.');
|
|
|
|
GetMem(pRecBuf,TblProps.iRecBufSize);
|
|
if not Assigned(pRecBuf) then
|
|
begin
|
|
Screen(' Error - Out of Memory.');
|
|
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
|
|
' Error - CloseCursor.');
|
|
ChkRslt(DbiCloseCursor(hFldList), DBIERR_NONE,
|
|
' Error - CloseCursor.');
|
|
FillTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Loop until the specified number of records have been written
|
|
to the table. }
|
|
for fRecCount := 1 to NumRecs do
|
|
begin
|
|
{ Make sure we're starting with a clean record buffer }
|
|
ChkRslt(DbiInitRecord(hCur, pRecBuf), DBIERR_NONE,
|
|
' Error - InitRecord.');
|
|
|
|
{ Start at the beginning of the field list. Setting the
|
|
cursor to the start of the table (i.e. BOF), does not leave
|
|
you on a record. You are effectively left on a crack.
|
|
Because of this, you will need to go to the next record in
|
|
the table to reach the first record of the table. }
|
|
FldCntr := 1;
|
|
ChkRslt(DbiSetToBegin(hFldList), DBIERR_NONE,
|
|
' Error - SetToBegin.');
|
|
|
|
{ This loop will use the previously opened field list to
|
|
drive what type of data is inserted into the table. }
|
|
while (DbiGetNextRecord(hFldList, dbiNOLOCK, @(fldDes),
|
|
nil) = DBIERR_NONE) do
|
|
begin
|
|
{ Put field data into the record buffer }
|
|
PutFieldSample(hCur, pRecBuf, FldCntr, @fldDes);
|
|
Inc(FldCntr);
|
|
end;
|
|
|
|
{ All fields have been inserted into the record buffer. Now
|
|
we need to append the record to the table... }
|
|
ChkRslt(DbiAppendRecord(hCur, pRecBuf),
|
|
DBIERR_NONE, ' Error - InsertRecord.');
|
|
|
|
{ Make sure to close all blobs (opened when data was put into
|
|
the record buffer). }
|
|
FldCntr := 1;
|
|
ChkRslt(DbiSetToBegin(hFldList), DBIERR_NONE,
|
|
' Error - SetToBegin.');
|
|
while (DbiGetNextRecord(hFldList, dbiNOLOCK, @(fldDes),
|
|
nil) = DBIERR_NONE) do
|
|
begin
|
|
if (fldDes.iFldType = fldBLOB) then
|
|
begin
|
|
ChkRslt(DbiFreeBlob(hCur, pRecBuf, FldCntr),
|
|
DBIERR_NONE, ' Error - FreeBlob.');
|
|
end;
|
|
Inc(FldCntr);
|
|
end;
|
|
end;
|
|
|
|
{ Free allocated record buffer }
|
|
FreeMem(pRecBuf,TblProps.iRecBufSize);
|
|
end;
|
|
|
|
{ Clean up and return }
|
|
ChkRslt(DbiCloseCursor(hFldList), DBIERR_NONE,
|
|
' Error - CloseCursor.');
|
|
|
|
ChkRslt(DbiCloseCursor(hCur), DBIERR_NONE,
|
|
' Error - CloseCursor.');
|
|
|
|
FillTable := DBIERR_NONE;
|
|
end;
|
|
|
|
{===============================================================
|
|
Function:
|
|
CreateAndFillTable(hDb, pTblDesc, NumRecs, phCur);
|
|
|
|
Input: hDb - Database handle
|
|
pTblDesc - Pointer to a descriptor for the table to
|
|
create
|
|
phCur - Pointer to table cursor (nil means do not
|
|
open the table after creating
|
|
|
|
Return: IDAPI return code.
|
|
|
|
Description:
|
|
Create a table based on the table descriptor
|
|
supplied. If 'phCur <> nil' then the table will be opened,
|
|
and the table cursor will be passed back thru this parameter.
|
|
================================================================ }
|
|
function CreateAndFillTable (hDb: hDBIDb; pTblDesc: pCRTblDesc;
|
|
NumRecs: Integer; var phCur: hDBICur): DBIResult;
|
|
var
|
|
rslt: DBIResult;
|
|
|
|
begin
|
|
Screen(' Creating '+pTblDesc^.szTblName+' table ...');
|
|
|
|
rslt := ChkRslt(DbiCreateTable(hDb, TRUE, pTblDesc^), DBIERR_NONE,
|
|
' Error - CreateTable.');
|
|
if (rslt = DBIERR_NONE) then
|
|
begin
|
|
{ Call the routine that will fill the table }
|
|
rslt := FillTable(hDb, pTblDesc^.szTblName, pTblDesc^.szTblType,
|
|
NumRecs);
|
|
|
|
{ Open the table if the create & fill worked }
|
|
if ((rslt = DBIERR_NONE) and (phCur <> nil)) then
|
|
begin
|
|
rslt := DbiOpenTable(hDb, pTblDesc^.szTblName,
|
|
pTblDesc^.szTblType, nil, nil, 0,
|
|
dbiREADWRITE, dbiOPENSHARED, xltFIELD,
|
|
FALSE, nil, phCur);
|
|
ChkRslt(rslt, DBIERR_NONE, ' Error - OpenTable.');
|
|
end;
|
|
end;
|
|
CreateAndFillTable := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
DisplayInMemoryTable();
|
|
|
|
Input: The cursor handle - which table to access
|
|
DisplayNRecs - How many records to display
|
|
0 - all records in the table
|
|
|
|
Return: Result of displaying the records in the table
|
|
|
|
Descrption:
|
|
This function will display all records in the table referenced
|
|
by the cursor. This function is used to display
|
|
in-memory and scema tables which do not support
|
|
the use of ReadBlock ( which is used in DislpayTable )
|
|
|
|
Note: This function will only display the columns
|
|
correctly when using a fixed pitch font.
|
|
===================================================================== }
|
|
function DisplayInMemoryTable (hCur: hDBICur;
|
|
uDisplayNRecs: longint): DBIResult;
|
|
var
|
|
rslt: DBIResult; { IDAPI function return value }
|
|
TblProps: CURProps; { Table Properties }
|
|
pFldDescs: pFLDDesc; { List of fields }
|
|
pRecBuf: pBYTE; { Record Buffer }
|
|
szFormat: PChar; { Contains an entire record (row) }
|
|
pszField: pPChar; { Array to contain the fields of
|
|
the table. }
|
|
szTemp: array[0..MAXLEN] of CHAR; { Temporary variable for
|
|
reading data }
|
|
const
|
|
uDefLength: Word = 15; { Default size of a field }
|
|
uFldNum: Word = 0; { Loop variable }
|
|
uCurCountRec: longint = 0; { Counter to keep track of how many
|
|
records have been displayed }
|
|
|
|
begin
|
|
|
|
uCurCountRec := 0;
|
|
uFldNum := 0;
|
|
|
|
GetMem (szFormat,1600 * sizeof(BYTE));
|
|
if (szFormat = nil) then
|
|
begin
|
|
DisplayInMemoryTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
rslt := ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
|
|
' Error - GetCursorProps.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
FreeMem(szFormat, 1600 * sizeof(BYTE));
|
|
DisplayInMemoryTable := rslt;
|
|
exit;
|
|
end;
|
|
|
|
{ Allocate space for the Record Buffer }
|
|
GetMem (pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
if not Assigned(pRecBuf) then
|
|
begin
|
|
DisplayInMemoryTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Allocate enough space to contain information (Field Descriptors)
|
|
about all the fields in the answer table. }
|
|
GetMem (pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
if not Assigned(pFldDescs) then
|
|
begin
|
|
FreeMem(szFormat, 1600 * sizeof(BYTE));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
DisplayInMemoryTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Get information about the fields. }
|
|
ChkRslt(DbiGetFieldDescs(hCur, pFldDescs), DBIERR_NONE,
|
|
' Error - QryGetFieldDescs.');
|
|
|
|
{ Allocate enough buffers to contain data from the fields in the
|
|
answer table. Also sets the width of non-fldZSTRING fields
|
|
(all data will be converted to Strings for display ) }
|
|
GetMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
|
|
{ Set up formatting for the fields }
|
|
SetupFields(TblProps, pFldDescs, pszField, uDefLength);
|
|
|
|
{ Display the names of the fields, aligned by column }
|
|
Screen('');
|
|
StrCopy(szFormat,' ');
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pFldDescs^.szName,
|
|
pFldDescs^.iUnits1+1));
|
|
Inc(pFldDescs);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
{ Display the header }
|
|
WriteLn(szFormat);
|
|
|
|
{ Get records from the table until the end of the table is reached
|
|
or the maximum number of records is reached.
|
|
Note that not all field types are supported. All supported field
|
|
types are displayed as Strings. }
|
|
if (uDisplayNRecs = 0) then
|
|
uDisplayNRecs := MaxLongInt; { Maximize value for uDisplayNRecs }
|
|
|
|
while (uCurCountRec < uDisplayNRecs) do
|
|
begin
|
|
rslt := DbiGetNextRecord(hCur, dbiNOLOCK, pRecBuf, nil);
|
|
if (rslt <> DBIERR_NONE) then
|
|
break;
|
|
Inc(uCurCountRec);
|
|
{ Fill the Record buffer with the field values }
|
|
GetFields(hCur, pFldDescs, pRecBuf, pszField, uDefLength);
|
|
|
|
{ Initialize szFormat to all zero's }
|
|
FillChar(szFormat^, sizeof(szFormat), #0);
|
|
{ Add leading blank space to the record }
|
|
StrCopy(szFormat,' ');
|
|
{ Add each field to be displayed, making certain that the
|
|
columns line up. }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pszField^,
|
|
pFldDescs^.iUnits1+1));
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
{ Display the record}
|
|
WriteLn(szFormat);
|
|
end;
|
|
{ Expect the End-Of-File error - just means that there
|
|
arn't any more records in the table. }
|
|
if (rslt = DBIERR_EOF) then
|
|
begin
|
|
rslt := DBIERR_NONE;
|
|
end;
|
|
|
|
{ Clean up }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
dispose(pszField^);
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pszField, TblProps.iFields);
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
FreeMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
FreeMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
FreeMem(szFormat, 1600 * sizeof(BYTE));
|
|
|
|
DisplayInMemoryTable := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
DisplayTable();
|
|
|
|
Input: The cursor handle - which table to access
|
|
DisplayNRecs - How many records to display
|
|
0 - display all records in the table
|
|
|
|
Return: Result of displaying the records in the table
|
|
|
|
Descrption:
|
|
This function will display all records in the table referenced
|
|
by the cursor. Records are read from the table in blocks,
|
|
making this function faster than the DisplayInMemoryTable()
|
|
function.
|
|
|
|
Note: This function will only display the columns
|
|
correctly when using a fixed pitch font.
|
|
===================================================================== }
|
|
function DisplayTable (hCur: hDBICur; uDisplayNRecs: LongInt): DBIResult;
|
|
var
|
|
rslt: DBIResult; { IDAPI function return value }
|
|
TblProps: CURProps; { Table Properties }
|
|
pFldDescs: pFLDDesc; { List of fields }
|
|
pRecBuf: pBYTE; { Record Buffer }
|
|
pszField: pPChar; { Array to contain the fields of the table. }
|
|
szFormat: PChar; { Contains an entire record (row) }
|
|
szTemp: array[0..MAXLEN] of CHAR; { Temporary variable for reading data }
|
|
const
|
|
uDefLength: Word = 15; { Default size of a field }
|
|
uFldNum: Word = 0; { Loop variable }
|
|
uCurCountRec: longint = 0; { Counter to keep track of how many
|
|
records have been displayed }
|
|
uMaxNumRecs: Word = 30; { Maximum number of record to read
|
|
from the table at a time }
|
|
uNumRecs: longint = 0; { Number of records Read in from the
|
|
table }
|
|
uCount: LongInt = 0; { Loop Variable }
|
|
|
|
begin
|
|
{ Allocate memory for the format string }
|
|
GetMem (szFormat, 1400);
|
|
if not Assigned(szFormat) then
|
|
begin
|
|
Screen(' Error - Out of Memory');
|
|
DisplayTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
{ Set szFormat = ' '}
|
|
szFormat[0] := ' ';
|
|
uCurCountRec := 0;
|
|
uNumRecs := 0;
|
|
uCount := 0;
|
|
uFldNum := 0;
|
|
|
|
{ Get the size of the record buffer }
|
|
rslt := ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
|
|
' Error - GetCursorProps.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
FreeMem(szFormat,1400);
|
|
DisplayTable := rslt;
|
|
exit;
|
|
end;
|
|
{ Allocate space for the Record Buffer }
|
|
GetMem (pRecBuf, TblProps.iRecBufSize * sizeof(BYTE) * uMaxNumRecs);
|
|
if not Assigned(pRecBuf) then
|
|
begin
|
|
FreeMem(szFormat, 1400);
|
|
DisplayTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Allocate enough space to contain information (Field Descriptors)
|
|
about all the fields in the answer table. }
|
|
GetMem (pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
if not Assigned(pFldDescs) then
|
|
begin
|
|
FreeMem(szFormat, 1400);
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE) * uMaxNumRecs);
|
|
DisplayTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Get information about the fields. }
|
|
ChkRslt(DbiGetFieldDescs(hCur, pFldDescs), DBIERR_NONE,
|
|
' Error - GetFieldDescs.');
|
|
|
|
{ Allocate enough buffers to contain data from the fields in the
|
|
answer table. Also sets the width of non-fldZSTRING fields
|
|
(all data will be converted to Strings for display ) }
|
|
GetMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
if not Assigned(pszField) then
|
|
begin
|
|
FreeMem(szFormat, 1400);
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE) * uMaxNumRecs);
|
|
FreeMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
DisplayTable := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
SetupFields(TblProps, pFldDescs, pszField, uDefLength);
|
|
|
|
{ Format the names of the fields, aligned by column }
|
|
StrCopy(szFormat,' ');
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pFldDescs^.szName,
|
|
pFldDescs^.iUnits1+1));
|
|
Inc(pFldDescs);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
|
|
{ Display the header information ( field names ) }
|
|
Screen(' ');
|
|
WriteLn(szFormat);
|
|
|
|
{ Get records from the table until the end of the table is reached
|
|
Note that not all field types are supported. All supported field
|
|
types are displayed as Strings.
|
|
The DbiReadBlock function is used in case field mapping
|
|
is taking place - the GetNextRec, GetPriorRec, and GetRelativeRec
|
|
functions do not take field mapping into consideration. }
|
|
uNumRecs := uMaxNumRecs; { Set the number of records to read from the
|
|
table as a block
|
|
if uCurCoutRec = 0, display all the records in the table }
|
|
if (uDisplayNRecs = 0) then
|
|
uDisplayNRecs := MaxLongInt; { Maximize value for uDisplayNRecs }
|
|
|
|
{ Get the records from the table and display }
|
|
repeat
|
|
{ Limit the number of records to be read from the table -
|
|
do not want to display more total records than is specified
|
|
in uDisplayNRecs }
|
|
if ((uNumRecs + uCurCountRec) > uDisplayNRecs) then
|
|
uNumRecs := uDisplayNRecs - uCurCountRec;
|
|
{ Read a block of records - reading more than one record at a
|
|
time is more efficient than reading records one at a time from
|
|
the table. }
|
|
rslt := DbiReadBlock(hCur, uNumRecs, pRecBuf);
|
|
if ((rslt <> DBIERR_EOF) and { DBIERR_EOF is an expected return }
|
|
(rslt <> DBIERR_NONE)) then { code- means cannot read more records }
|
|
begin
|
|
FreeMem(szFormat, 1400);
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
dispose(pszField^);
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
FreeMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
FreeMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE) * uMaxNumRecs);
|
|
FreeMem(szFormat, 1400);
|
|
DisplayTable := rslt;
|
|
exit;
|
|
end;
|
|
uCount := 0;
|
|
while (uCount < uNumRecs) do
|
|
begin
|
|
Inc(uCount);
|
|
Inc(uCurCountRec);
|
|
|
|
{ Fill the Record buffer with the field values }
|
|
GetFields(hCur, pFldDescs,
|
|
PChar(pRecBuf) + ((uCount-1)*TblProps.iRecBufSize),
|
|
pszField, uDefLength);
|
|
|
|
{ Add leading blank space to the record }
|
|
StrCopy(szFormat,' ');
|
|
{ Add each field to be displayed, making certain that the
|
|
columns line up. }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pszField^,
|
|
pFldDescs^.iUnits1));
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
{ Display the record }
|
|
WriteLn(szFormat);
|
|
end; { for ... uCount }
|
|
|
|
{ While ReadBlock reads as many records as are supposed to be
|
|
batched (uMaxNumRecs) and the maximum number of records have not
|
|
been read from the table. Not having read the number of records
|
|
specified in uMaxNumRecs indicates that the end of the table has
|
|
been reached. }
|
|
until ((uNumRecs <> uMaxNumRecs) or
|
|
(uCurCountRec >= uDisplayNRecs));
|
|
|
|
{ Expect the End-Of-File error - just means that there
|
|
arn't any more records in the table. }
|
|
if (rslt = DBIERR_EOF) then
|
|
rslt := DBIERR_NONE;
|
|
|
|
{ Clean up }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
dispose(pszField^);
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
|
|
FreeMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
FreeMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE) * uMaxNumRecs);
|
|
FreeMem(szFormat, 1400);
|
|
|
|
DisplayTable := DBIERR_NONE;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
PutFieldSample(hCur, pRecBuf, FldNum, pfldDesc);
|
|
|
|
Input: hCur - The handle for the table to fill
|
|
pRecBuf - The record buffer to insert data into
|
|
FldNum - The field we are generating
|
|
pfldDesc - A descriptor that describes the field to generate
|
|
|
|
Return: Result returned from DbiPutField().
|
|
|
|
Description:
|
|
This routine is used to put field data into a record
|
|
buffer. Note that all LOGICAL field types are covered. You
|
|
will need to refer to documentation, or run the DRVCAPS.C
|
|
example for PHYSICAL to LOGICAL field mappings.
|
|
===================================================================== }
|
|
function PutFieldSample (hCur: hDBICur; pRecBuf: pBYTE; FldNum: Word;
|
|
pfldDesc: pFLDDesc): DBIResult;
|
|
var
|
|
pBuf: pBYTE; { Buffer which contains the record data }
|
|
rslt: DBIResult; { Return value from Paradox functions }
|
|
i: Integer; { Loop counter }
|
|
BlobSize: Integer; { Size of the BLOB }
|
|
Bool: Boolean; { Used for fldBOOL }
|
|
i16: Integer; { Used for fldINT16 }
|
|
ui16: Word; { Used for fldUINT16 }
|
|
i32: LongInt; { Used for fldINT32 }
|
|
ui32: LongInt; { Used for fldUINT32 }
|
|
fFloat: Double; { Used for fldFLOAT }
|
|
fmBcd: FMTBcd; { Used for fldBCD }
|
|
dDate: DbiTypes.DATE; { Used for fldDATE }
|
|
tTime: DbiTypes.TIME; { Used for fldTIME }
|
|
tStamp: DbiTypes.TIMESTAMP; { Used for fldTIMESTAMP }
|
|
month: Word; { Used in generating the date }
|
|
day: Word; { Used in generating the date }
|
|
year: Word; { Used in generating the date }
|
|
hour: Word; { Used in generating the time }
|
|
min: Word; { Used in generating the time }
|
|
sec: Word; { Used in generating the time }
|
|
begin
|
|
{ Allocate a generic buffer (used for string & blob fields) }
|
|
GetMem (pBuf,4096);
|
|
|
|
{ This switch contains sample code that demonstrates how to
|
|
insert a field of any type into a record buffer. Random data
|
|
is used by this example. }
|
|
case (pfldDesc^.iFldType) of
|
|
fldBYTES,
|
|
fldZSTRING:
|
|
begin
|
|
StrPCopy(PChar(pBuf), 'Field #'+IntToStr(FldNum));
|
|
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, pBuf);
|
|
end;
|
|
fldDATE:
|
|
begin
|
|
{ Randomly generate & encode a date }
|
|
month := random(11) + 1;
|
|
day := random(20) + 1;
|
|
year := random(98) + 1900;
|
|
ChkRslt(DbiDateEncode(month, day, year, dDate),
|
|
DBIERR_NONE, ' Error - DateEncode.');
|
|
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(dDate));
|
|
end;
|
|
fldBLOB:
|
|
begin
|
|
{ Generate a blob from 10-4010 bytes }
|
|
BlobSize := (random(4000))+10;
|
|
|
|
StrCopy(PChar(pBuf), 'BLOB example ');
|
|
{ Write data to the BLOB field }
|
|
for i := 0 to (BlobSize mod 11) do
|
|
begin
|
|
StrCat(PChar(pBuf), 'BLOB test ');
|
|
end;
|
|
|
|
{ Init the blob header (contents defined by IDAPI client) }
|
|
if ((pfldDesc^.iSubType = fldstFMTMEMO) or
|
|
(pfldDesc^.iSubType = fldstOLEOBJ) or
|
|
(pfldDesc^.iSubType = fldstGRAPHIC)) then
|
|
begin
|
|
FillChar(pBuf^, 8, #0);
|
|
end;
|
|
|
|
{ Open the blob prior to putting }
|
|
ChkRslt(DbiOpenBlob(hCur, pRecBuf, FldNum, dbiREADWRITE),
|
|
DBIERR_NONE, ' Error - OpenBlob.');
|
|
|
|
{ Put the blob. Note that DbiFreeBlob() will be
|
|
called after the record is inserted! }
|
|
rslt := DbiPutBlob(hCur, pRecBuf, FldNum, 0, BlobSize,
|
|
pBuf);
|
|
end;
|
|
fldBOOL:
|
|
begin
|
|
{ Boolean fields are either TRUE or FALSE }
|
|
if (random(100) < 50) then
|
|
Bool := True
|
|
else
|
|
Bool := False;
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(Bool));
|
|
end;
|
|
fldINT16:
|
|
begin
|
|
i16 := (random(120));
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(i16));
|
|
end;
|
|
fldBCD:
|
|
begin
|
|
fFloat := (random(10000) / 1.21324);
|
|
ChkRslt(DbiBcdFromFloat(fFloat, pfldDesc^.iUnits1,
|
|
pfldDesc^.iUnits2, fmBcd),
|
|
DBIERR_NONE, ' Error - BcdFromFloat.');
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @fmBcd);
|
|
end;
|
|
fldLOCKINFO:
|
|
begin
|
|
rslt := 0;
|
|
end;
|
|
fldUINT16:
|
|
begin
|
|
ui16 := (random(120));
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(ui16));
|
|
end;
|
|
fldINT32:
|
|
begin
|
|
{ Put the data into the record buffer if it is not an
|
|
Auto Increment field. }
|
|
if (pfldDesc^.iSubType <> fldstAUTOINC) then
|
|
begin
|
|
i32 := (random(10000));
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(i32));
|
|
end
|
|
else
|
|
{ Don't have to put a value into an Auto Increment Field,
|
|
but do have to make certain to not return an error. }
|
|
rslt := 0;
|
|
end;
|
|
fldUINT32:
|
|
begin
|
|
ui32 := (random(10000));
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(ui32));
|
|
end;
|
|
fldFLOAT:
|
|
begin
|
|
fFloat := (random(10000) / 1.21324);
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @fFloat);
|
|
end;
|
|
fldTIME:
|
|
begin
|
|
{ Randomize, and encode, a time value }
|
|
hour := random(23) + 1;
|
|
min := random(59) + 1;
|
|
sec := random(59999);
|
|
ChkRslt(DbiTimeEncode(hour, min, sec, tTime), DBIERR_NONE,
|
|
' Error - TimeEncode.');
|
|
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(tTime));
|
|
end;
|
|
fldTIMESTAMP:
|
|
begin
|
|
{ Encode a date and a time }
|
|
month := random(11) + 1;
|
|
day := random(20) + 1;
|
|
year := random(98)+1900;
|
|
ChkRslt(DbiDateEncode(month, day, year, dDate),
|
|
DBIERR_NONE, ' Error - DateEncode.');
|
|
hour := random(23) + 1;
|
|
min := random(59) + 1;
|
|
sec := random(59999);
|
|
ChkRslt(DbiTimeEncode(hour, min, sec, tTime),
|
|
DBIERR_NONE, ' Error - TimeEncode.');
|
|
|
|
{ Now encode, and put, the time stamp }
|
|
ChkRslt(DbiTimeStampEncode(dDate, tTime, tStamp),
|
|
DBIERR_NONE, ' Error - TimeStampEncode');
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @tStamp);
|
|
end;
|
|
fldVARBYTES:
|
|
begin
|
|
{ Init the size (1st two bytes) & contents }
|
|
pBuf^ := pfldDesc^.iUnits1 - 2;
|
|
Inc(pBuf);
|
|
for i := 2 to pfldDesc^.iUnits1 do
|
|
begin
|
|
Inc(pBuf);
|
|
pBuf^ := random(90)+32;
|
|
end;
|
|
{ Put the data into the record buffer }
|
|
rslt := DbiPutField(hCur, FldNum, pRecBuf, @(pBuf));
|
|
end;
|
|
else
|
|
begin
|
|
rslt := DBIERR_INVALIDFLDTYPE;
|
|
end;
|
|
end;
|
|
{ Determine if any of the previous DbiPutField functions failed. }
|
|
ChkRslt(rslt, DBIERR_NONE, ' Error - PutField.');
|
|
|
|
{ Clean up and return }
|
|
freeMem (pBuf, 4096);
|
|
PutFieldSample := rslt;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
MakeFullPath (PChar szDirectory)
|
|
|
|
Input: szDirectory - String to contain the path to the Tables
|
|
directory.
|
|
|
|
Return: DBIERR_SUCCESS
|
|
|
|
Description:
|
|
This function is used to get the fully qualified path to
|
|
the EXAMPLES\TABLES directory. This function will only work
|
|
when the EXAMPLES\TABLES directory resides in ..\TABLES.
|
|
===================================================================== }
|
|
function MakeFullPath (szDirectory: PChar): DBIResult;
|
|
var
|
|
iLoop: integer; { Loop counter }
|
|
TmpPtr: PChar;
|
|
|
|
const
|
|
szRelDirectory = '..\TABLES';
|
|
szTablesDirectory = '\TABLES';
|
|
|
|
begin
|
|
{ Get the current working directory }
|
|
StrPCopy(szDirectory, ParamStr(0));
|
|
{ Remove the .EXE and one directory from the full path }
|
|
for iLoop := 1 to 2 do
|
|
begin
|
|
TmpPtr := StrRScan(szDirectory, '\');
|
|
{ if the path cannot be determined, use a relative path }
|
|
if TmpPtr = nil then
|
|
begin
|
|
StrCopy(szDirectory, szRelDirectory);
|
|
Break;
|
|
end;
|
|
TmpPtr^ := #0;
|
|
{ Place the tables directory on the new path }
|
|
if iLoop = 2 then
|
|
StrCat(szDirectory, szTablesDirectory);
|
|
end;
|
|
MakeFullPath := dbiErr_None;
|
|
end;
|
|
|
|
{ =====================================================================
|
|
Function:
|
|
MakeFullTblPath (pszDirectory, pszRelativeDirectory)
|
|
|
|
Input: pszDirectory - String to contain the path to the tables
|
|
directory.
|
|
pszRelativeDirectory - String which contains the relative offset
|
|
from the current directory.
|
|
|
|
Return: int - If the directory exists
|
|
|
|
Description:
|
|
This function is used to get the fully qualified path to
|
|
the directory which will contain the tables. This function
|
|
will only work when pszRelativeDirectory contains either "."
|
|
an absolute path, or <..\\>TABLES.
|
|
===================================================================== }
|
|
function MakeFullTblPath (pszDirectory :PChar;
|
|
pszRelativeDirectory: PChar) :DBIResult;
|
|
var
|
|
iExists: integer; { Does the directory exist? }
|
|
iLen: integer; { Length of the path }
|
|
iLoop: integer; { Loop counter }
|
|
iDepth: integer; { How relative the directory is }
|
|
const
|
|
cDrive: Byte = 3;
|
|
|
|
begin
|
|
|
|
{ Assume absolute path if second character is a ':'. }
|
|
if (pszRelativeDirectory[1] = ':') then
|
|
begin
|
|
StrCopy(pszDirectory, pszRelativeDirectory);
|
|
end
|
|
else
|
|
begin
|
|
if ( StrComp(pszRelativeDirectory, '.') = 0) then
|
|
begin
|
|
{ Get the current working directory. }
|
|
(* GetCurDir(pszDirectory, cDrive); *)
|
|
end
|
|
else
|
|
begin
|
|
{ Get the current working directory. }
|
|
(* GetCurDir(pszDirectory, cDrive); *)
|
|
iLen := strlen(pszDirectory);
|
|
iDepth := 0;
|
|
|
|
{ Determine where in the string the last directory on
|
|
the path starts }
|
|
while(StrLComp(@pszRelativeDirectory[iDepth * 3], '..\',3) = 0) do
|
|
begin
|
|
for iLoop := iLen downto -1 do
|
|
{ If the current character is equal to '\', we found
|
|
the start of last directory on the path }
|
|
if (pszDirectory[iLoop] = '\') then
|
|
break;
|
|
|
|
iLen := iLoop - 1;
|
|
iDepth := iDepth + 1;
|
|
end;
|
|
{ Copy the 'TABLES' directory to form the full path to the tables.
|
|
Need to move past szDirectory past the '\' and szTblDirectory
|
|
past the '..\'. }
|
|
StrCopy( @pszDirectory[iLoop+1],
|
|
@pszRelativeDirectory[iDepth * 3]);
|
|
end;
|
|
end;
|
|
|
|
MakeFullTblPath := DBIERR_NONE;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
DisplayNextRecord(HDBICur hCur)
|
|
|
|
Input: Handle to the cursor.
|
|
|
|
Return: DBIERR_SUCCESS
|
|
|
|
Description:
|
|
This function will call DisplayInMemoryTable() with a value
|
|
of 1 for the second parameter. This way it will display the
|
|
next record.
|
|
===================================================================== }
|
|
function DisplayNextRecord(hCur: hDBICur): DBIResult;
|
|
begin
|
|
ChkRslt(DisplayInMemoryTable(hCur, 1), DBIERR_NONE, ' Error - '+
|
|
'DisplayNextRecord');
|
|
|
|
DisplayNextRecord := DBIERR_NONE;
|
|
end;
|
|
|
|
{=====================================================================
|
|
Function:
|
|
DisplayCurrentRecord();
|
|
|
|
Input: The cursor handle - which table to access
|
|
|
|
Return: Result of displaying the records in the table
|
|
|
|
Descrption:
|
|
This function will display the current record only.
|
|
|
|
Note: This function will only display the columns
|
|
correctly when using a fixed pitch font.
|
|
===================================================================== }
|
|
function DisplayCurrentRecord (hCur: hDBICur): DBIResult;
|
|
var
|
|
rslt: DBIResult; { IDAPI function return value }
|
|
TblProps: CURProps; { Table Properties }
|
|
pFldDescs: pFLDDesc; { List of fields }
|
|
pRecBuf: pBYTE; { Record Buffer }
|
|
pszField: pPChar; { Array to contain the fields of the
|
|
table. }
|
|
szFormat: PChar; { Contains an entire record (row) }
|
|
uFldNum: Word; { Loop variable }
|
|
szTemp: array[0..MAXLEN] of CHAR;{ Temporary variable for reading data }
|
|
const
|
|
uDefLength: Word = 15; { Default size of a field }
|
|
|
|
begin
|
|
|
|
GetMem(szFormat, 1600*sizeof(BYTE));
|
|
if not Assigned(szFormat) then
|
|
DisplayCurrentRecord := DBIERR_NOMEMORY;
|
|
|
|
rslt := ChkRslt(DbiGetCursorProps(hCur, TblProps), DBIERR_NONE,
|
|
' Error - GetCursorProps.');
|
|
if (rslt <> DBIERR_NONE) then
|
|
begin
|
|
FreeMem(szFormat, 1600*SizeOf(BYTE));
|
|
DisplayCurrentRecord := rslt;
|
|
exit;
|
|
end;
|
|
|
|
{ Allocate space for the Record Buffer }
|
|
GetMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
if not Assigned(pRecBuf) then
|
|
begin
|
|
DisplayCurrentRecord := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Allocate enough space to contain information (Field Descriptors)
|
|
about all the fields in the answer table. }
|
|
GetMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
if not Assigned(pFldDescs) then
|
|
begin
|
|
FreeMem(szFormat, 1600*SizeOf(BYTE));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
DisplayCurrentRecord := DBIERR_NOMEMORY;
|
|
exit;
|
|
end;
|
|
|
|
{ Get information about the fields. }
|
|
ChkRslt(DbiGetFieldDescs(hCur, pFldDescs), DBIERR_NONE,
|
|
' Error - QryGetFieldDescs.');
|
|
|
|
{ Allocate enough buffers to contain data from the fields in the
|
|
answer table. Also sets the width of non-fldZSTRING fields
|
|
(all data will be converted to Strings for display ) }
|
|
GetMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
|
|
{ Set up formatting for the fields }
|
|
SetupFields(TblProps, pFldDescs, pszField, uDefLength);
|
|
|
|
{ Display the names of the fields, aligned by column }
|
|
Screen('');
|
|
StrCopy(szFormat,' ');
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pFldDescs^.szName,
|
|
pFldDescs^.iUnits1+1));
|
|
Inc(pFldDescs);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
{ Display the header }
|
|
WriteLn(szFormat);
|
|
|
|
ChkRslt(DbiGetRecord(hCur, dbiNOLOCK, pRecBuf, nil), DBIERR_NONE,
|
|
' Error - GetRecord');
|
|
|
|
{ Fill the Record buffer with the field values }
|
|
GetFields(hCur, pFldDescs, pRecBuf, pszField, uDefLength);
|
|
|
|
{ Initialize szFormat to all zero's }
|
|
FillChar(szFormat^, sizeof(szFormat), #0);
|
|
{ Add leading blank space to the record }
|
|
StrCopy(szFormat,' ');
|
|
|
|
{ Add each field to be displayed, making certain that the
|
|
columns line up. }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
StrCat(szFormat, RightPad(szTemp, pszField^,
|
|
pFldDescs^.iUnits1+1));
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
{ Display the record }
|
|
WriteLn(szFormat);
|
|
|
|
{ Expect the End-Of-File error - just means that there
|
|
arn't any more records in the table. }
|
|
if (rslt = DBIERR_EOF) then
|
|
rslt := DBIERR_NONE;
|
|
|
|
{ Clean up }
|
|
for uFldNum := 1 to TblProps.iFields do
|
|
begin
|
|
dispose(pszField^);
|
|
Inc(pFldDescs);
|
|
Inc(pszField);
|
|
end;
|
|
Dec(pFldDescs, TblProps.iFields);
|
|
Dec(pszField, TblProps.iFields);
|
|
|
|
FreeMem(pszField, TblProps.iFields * sizeof(PChar));
|
|
FreeMem(pFldDescs, TblProps.iFields * sizeof(FLDDesc));
|
|
FreeMem(pRecBuf, TblProps.iRecBufSize * sizeof(BYTE));
|
|
FreeMem(szFormat, 1600*sizeof(BYTE));
|
|
|
|
DisplayCurrentRecord := rslt;
|
|
end;
|
|
|
|
end.
|