{codecitation class="brush: pascal; gutter: false;" width="600px"}
unit ADO;
{This unit provides a quick access
It handles all it's own exceptions
It assumes it is working with SQL Server, on a PLC Database
If an exception is thrown with a [PLCErr] suffix:
the suffix is removed, and ErrMsg is set to the remaining string
otherwise
the whole exception is reported in ErrMsg
Either way, the function
Globals:
ConnectionString
— Connection String used for connecting
Functions:
ADOStart:Boolean;
ADOReset:Boolean;
ADOStop:Boolean;
Recordsets
RSOpen (SQL:string;adRSType,adLockType,adCmdType:integer;UseServer:Boolean):Boolean;
RSClose:Boolean;
Normal Command Procedures
CMDExec (SQL:string;adCmdType:integer):Boolean;
Parametric Procedures
PRMClear:Boolean;
PRMSetSP (StoredProcedure:string;WithClear:Boolean):Boolean;
PRMAdd (ParamName:string;ParamType,ParamIO,ParamSize:integer;Val:variant):Boolean;
PRMSetParamVal (ParamName:string;val:variant):Boolean;
PRMGetParamVal (ParamName:string;var val:variant):Boolean;
Field Operations
function SQLStr (str:string;SQLStrType:TSQLStrType);
function SentenceCase (str:string):string;
--to convert from 'FIELD_NAME' -> 'Field Name' call
SQLStr (SentenceCase (txt),ssFromSQL);
}
interface
uses OLEAuto, sysutils;
const
{Param Data Types}
adInteger = 3;
adSingle = 4;
adDate = 7;
adBoolean = 11;
adTinyInt = 16;
adUnsignedTinyInt = 17;
adDateTime = 135;
advarChar = 200;
{Param Directions}
adParamInput = 1;
adParamOutput = 2;
adParamReturnValue = 4;
{Command Types}
adCmdText = 1;
adCmdTable = 2;
adCmdStoredProc = 4;
adCmdTableDirect = 512;
adCmdFile = 256;
{Cursor/RS Types}
adOpenForwardOnly = 0;
adOpenKeyset = 1;
adOpenDynamic = 2;
adOpenStatic = 3;
{Lock Types}
adLockReadOnly = 1;
adLockOptimistic = 3;
{Cursor Locations}
adUseServer = 2;
adUseClient = 3;
function ADOReset: Boolean;
function ADOStop: Boolean;
function RSOpen (SQL: string; adRSType, adLockType, adCmdType: integer;
UseServer: Boolean): Boolean;
function RSClose: Boolean;
function CMDExec (SQL: string; adCmdType: integer): Boolean;
function PRMClear: Boolean;
function PRMSetSP (StoredProcedure: string; WithClear: Boolean): Boolean;
function PRMAdd (ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
variant): Boolean;
function PRMSetParamVal (ParamName: string; val: variant): Boolean;
function PRMGetParamVal (ParamName: string; var val: variant): Boolean;
type
TSQLStrType = (ssToSQL, ssFromSQL);
function SQLStr (str: string; SQLStrType: TSQLStrType): string;
function SentenceCase (str: string): string;
var
adocn, adors, adocmd, adocmdPrm: variant;
ConnectionString, ErrMsg: string;
ADOActive: boolean = false;
implementation
var
UsingConnection: Boolean;
function ADOStart: Boolean;
begin
//Get the Object References
try
adocn:= CreateOLEObject ('ADODB.Connection');
adors:= CreateOLEObject ('ADODB.Recordset');
adocmd:= CreateOLEObject ('ADODB.Command');
adocmdprm:= CreateOLEObject ('ADODB.Command');
result:= true;
except
on E:
begin
ErrMsg:= e.message;
Result:= false;
end;
end;
ADOActive:= result;
end;
function ADOReset: Boolean;
begin
Result:= false;
//Ensure a
if not (ADOStop) then
exit;
//Restart all the ADO References
if not (ADOStart) then
exit;
//Wire up the Connections
//If the ADOconnetion fails, all objects will use the connection string
//
try
adocn.ConnectionString:= ConnectionString;
adocn.open;
adors.activeconnection:= adocn;
adocmd.activeconnection:= adocn;
adocmdprm.activeconnection:= adocn;
UsingConnection:= true;
except
try
adocn:= unassigned;
UsingConnection:= false;
adocmd.activeconnection:= ConnectionString;
adocmdprm.activeconnection:= ConnectionString;
except
on e:
begin
ErrMsg:= e.message;
exit;
end;
end;
end;
Result:= true;
end;
function ADOStop: Boolean;
begin
try
if not (varisempty (adocn)) then
begin
adocn.close;
adocn:= unassigned;
end;
adors:= unassigned;
adocmd:= unassigned;
adocmdprm:= unassigned;
result:= true;
except
on E:
begin
ErrMsg:= e.message;
Result:= false;
end;
end;
ADOActive:= false;
end;
function RSOpen (SQL: string; adRSType, adLockType, adCmdType: integer;
UseServer: Boolean): Boolean;
begin
result:= false;
//Have two attempts at getting the required Recordset
if
begin
try
if
adors.CursorLocation:= adUseServer
else
adors.CursorLocation:= adUseClient;
adors.open (SQL,, adRSType, adLockType, adCmdType);
except
if not (ADOReset) then
exit;
try
if
adors.CursorLocation:= adUseServer
else
adors.CursorLocation:= adUseClient;
adors.open (SQL,, adRSType, adLockType, adCmdType);
except
on E:
begin
ErrMsg:= e.message;
exit;
end;
end;
end;
end
else
begin
//Use the Connetcion String to establish
try
adors.open (SQL, ConnectionString, adRSType, adLockType, adCmdType);
except
if not (ADOReset) then
exit;
try
adors.open (SQL, ConnectionString, adRSType, adLockType, adCmdType);
except
on E:
begin
ErrMsg:= e.message;
exit;
end;
end;
end;
end;
Result:= true;
end;
function RSClose: Boolean;
begin
try
adors.Close;
result:= true;
except
on E:
begin
ErrMsg:= e.message;
result:= false;
end;
end;
end;
function CMDExec (SQL: string; adCmdType: integer): Boolean;
begin
result:= false;
//Have two attempts at the execution..
try
adocmd.commandtext:= SQL;
adocmd.commandtype:= adCmdType;
adocmd.execute;
except
try
if not (ADOReset) then
exit;
adocmd.commandtext:= SQL;
adocmd.commandtype:= adCmdType;
adocmd.execute;
except
on e:
begin
ErrMsg:= e.message;
exit;
end;
end;
end;
result:= true;
end;
function PRMClear: Boolean;
var
i: integer;
begin
try
for i:=
begin
adocmdprm.parameters.delete (0);
end;
result:= true;
except
on e:
begin
ErrMsg:= e.message;
result:= false;
end;
end;
end;
function PRMSetSP (StoredProcedure: string; WithClear: Boolean): Boolean;
begin
result:= false;
//Have two attempts at setting the Stored Procedure…
try
adocmdprm.commandtype:= adcmdStoredProc;
adocmdprm.commandtext:= StoredProcedure;
if
if not (PRMClear) then
exit;
result:= true;
except
try
if not (ADOReset) then
exit;
adocmdprm.commandtype:= adcmdStoredProc;
adocmdprm.commandtext:= StoredProcedure;
//NB: No need to clear the parameters, as an ADOReset will have
result:= true;
except
on e:
begin
ErrMsg:= e.message;
end;
end;
end;
end;
function PRMAdd (ParamName: string; ParamType, ParamIO, ParamSize: integer; Val:
variant): Boolean;
var
DerivedParamSize: integer;
begin
//Only try once to add the parameter (a call to ADOReset would reset EVERYTHING!!)
try
case
adInteger: DerivedParamSize:= 4;
adSingle: DerivedParamSize:= 4;
adDate: DerivedParamSize:= 8;
adBoolean: DerivedParamSize:= 1;
adTinyInt: DerivedParamSize:= 1;
adUnsignedTinyInt: DerivedParamSize:= 1;
adDateTime: DerivedParamSize:= 8;
advarChar: DerivedParamSize:= ParamSize;
end;
adocmdprm.parameters.append (adoCmdPrm.createparameter (ParamName, ParamType,
ParamIO, DerivedParamSize, Val));
except
on e:
begin
ErrMsg:= e.message;
end;
end;
end;
function PRMSetParamVal (ParamName: string; val: variant): Boolean;
begin
//Only try once to set the parameter (a call to ADOReset would reset EVERYTHING!!)
try
adocmdprm.Parameters[ParamName].Value:= val;
result:= true;
except
on e:
begin
ErrMsg:= e.message;
result:= false;
end;
end;
end;
function PRMGetParamVal (ParamName: string; var val: variant): Boolean;
begin
//Only try once to read the parameter (a call to ADOReset would reset EVERYTHING!!)
try
val:= adocmdprm.Parameters[ParamName].Value;
result:= true;
except
on e:
begin
ErrMsg:= e.message;
result:= false;
end;
end;
end;
function SQLStr (str: string; SQLStrType: TSQLStrType): string;
var
FindChar, ReplaceChar: char;
begin
{Convert ' '->'_' for ssToSQL (remove spaces)
Convert '_'->' ' for ssFromSQL (remove underscores)}
case
ssToSQL:
begin
FindChar:= ' ';
ReplaceChar:= '_';
end;
ssFromSQL:
begin
FindChar:= '_';
ReplaceChar:= ' ';
end;
end;
result:= str;
while Pos (FindChar, result) >
Result[Pos (FindChar, result)]:= ReplaceChar;
end;
function SentenceCase (str: string): string;
var
tmp: char;
i {,len}: integer;
NewWord: boolean;
begin
NewWord:= true;
result:= str;
for i:=
begin
if (result[i] = ' ') or (result[i] = '_') then
NewWord:= true
else
begin
tmp:= result[i];
if
begin
NewWord:= false;
result[i]:= chr (ord (result[i]) or 64); //Set bit
end
else
result[i]:= chr (ord (result[i]) and 191); //reset bit
end;
end;
{This was the original way of doing it, but
and it all seemed
if str'' then
begin
tmp:=LowerCase (str);
len:=length (tmp);
tmp:=Uppercase (copy (tmp, 1,1)) copy (tmp, 2,len);
i:=pos ('_',tmp);
while i0 do
begin
tmp:=copy (tmp, 1,i-1) ' ' Uppercase (copy (tmp,i 1,1)) copy (tmp,i
i:=pos ('_',tmp);
end;
end;
result:=tmp;}
end;
end.
{/codecitation}