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

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
.

Другое по теме:

• ADO.OLEDB.JET - Access Violation при передаче неполного параметра
• Запись картинки в ADO таблицу
• Из Paradox в Access при помощи ADO