Delphi World - Быстрый доступ к ADO
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Быстрый доступ к 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.

Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования