{codecitation class="brush: pascal; gutter: false;" width="600px"}

unit ADO;

{This unit provides a quick access into ADO

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 call fails.

Globals: adocn — connection which all other ADO objects use

adors — Recordset

adocmd — Command Object

adocmdprm — Command Object set aside for Parametric querying

ConnectionString

— Connection String used for connecting

ErrMsg — Last Error Message

ADOActive — Indicator as to whether ADO has been started yet

Functions:

General ADO

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: Exception do

begin

ErrMsg:= e.message;

Result:= false;

end;

end;

ADOActive:= result;

end;

function ADOReset: Boolean;

begin

Result:= false;

//Ensure a clean slate…

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

// directly — poorer performance, but it works!!

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: exception do

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: Exception do

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 UsingConnection then

begin

try

if UseServer then

adors.CursorLocation:= adUseServer

else

adors.CursorLocation:= adUseClient;

adors.open (SQL,, adRSType, adLockType, adCmdType);

except

if not (ADOReset) then

exit;

try

if UseServer then

adors.CursorLocation:= adUseServer

else

adors.CursorLocation:= adUseClient;

adors.open (SQL,, adRSType, adLockType, adCmdType);

except

on E: Exception do

begin

ErrMsg:= e.message;

exit;

end;

end;

end;

end

else

begin

//Use the Connetcion String to establish a link

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: Exception do

begin

ErrMsg:= e.message;

exit;

end;

end;

end;

end;

Result:= true;

end;

function RSClose: Boolean;

begin

try

adors.Close;

result:= true;

except

on E: Exception do

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: exception do

begin

ErrMsg:= e.message;

exit;

end;

end;

end;

result:= true;

end;

function PRMClear: Boolean;

var

i: integer;

begin

try

for i:= 0 to (adocmdprm.parameters.count) — 1 do

begin

adocmdprm.parameters.delete (0);

end;

result:= true;

except

on e: exception do

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 WithClear then

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 done this..

result:= true;

except

on e: exception do

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 ParamType of

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: exception do

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: exception do

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: exception do

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 SQLStrType of

ssToSQL:

begin

FindChar:= ' ';

ReplaceChar:= '_';

end;

ssFromSQL:

begin

FindChar:= '_';

ReplaceChar:= ' ';

end;

end;

result:= str;

while Pos (FindChar, result) > 0 do

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:= 1 to Length (str) do

begin

if (result[i] = ' ') or (result[i] = '_') then

NewWord:= true

else

begin

tmp:= result[i];

if NewWord then

begin

NewWord:= false;

result[i]:= chr (ord (result[i]) or 64); //Set bit 6 — makes uppercase

end

else

result[i]:= chr (ord (result[i]) and 191); //reset bit 6 — makes lowercase

end;

end;

{This was the original way of doing it, but I wanted to look for spaces or '_'s,

and it all seemed problematic — if I find a better way another day, I'll alter the above…

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 2,len-i);

i:=pos ('_',tmp);

end;

end;

result:=tmp;}

end;

end.

{/codecitation}

• Назад
• Вперёд