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

Previous  Top  Next

    
 

 

 

Code:

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 i<>0 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.

 

 

©Drkb::02666

       

Взято с http://delphiworld.narod.ru