Приветствую Вас Гость | RSS

Меню сайта

Реклама

Категории раздела
ADO [17]
ASCII и CSV [12]
Access [20]
Alias [24]
BDE [37]
BLOB поля [19]
Clipper [2]
DB2 [2]
DBASE и DBF [26]
Fox Pro [1]
Interbase [21]
MSSQL [0]
ODBC [10]
Oracle [0]
Paradox [0]
SQL [29]
Sybase [1]
База данных [0]
Закладки [2]
Записи [0]
Индексы [10]
Компоненты и Базы данных [0]
Модуль данных [3]
Отчеты [2]
Ошибки БД [17]
Поиск [16]
Поля [0]
Сортировка и Фильтр [6]
Таблицы [0]

Наш опрос
Оцените мой сайт
Всего ответов: 30

Статистика

Онлайн всего: 1
Гостей: 1
Пользователей: 0

Форма входа

Главная » Статьи » Базы данных » ADO

Быстрый доступ к 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 | Добавил: Skinner (03.07.2008)
Просмотров: 571 | Рейтинг: 0.0/0
  Delphi Lab   Главная   Регистрация   Вход  
Интересная Цитата

Поиск

Магазин


Copyright MyCorp © 2024 Хостинг от uCoz