Быстрый доступ к ADO

{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}

Добавить комментарий