Быстрый доступ к 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.

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