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.