{codecitation class="brush: pascal; gutter: false;" width="600px"}

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 i0 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.

{/codecitation}

{codecitation class="brush: pascal; gutter: false;" width="600px"}

Автор: Nomadic

Итак, хочу поделиться некоторыми достижениями… так на всякий случай. Если у вас вдруг потребуется сделать в своей программке доступ к базе данных, а BDE использовать будет неохота (или невозможно) — то есть довольно приятный вариант: использовать ActiveX Data Objects. Однако с их использованием есть некоторые проблемы, и одна из них это как передавать Optional параметры, которые вроде как можно не указывать. Однако, если вы работаете с ADO по-человечески, а не через тормозной IDispatch.Invoke то это превращается в головную боль. Вот как от нее избавляться:

var

OptionalParam: OleVariant;

VarData: PVarData;

begin

OptionalParam:= DISP_E_PARAMNOTFOUND;

VarData:= @OptionalParam;

VarData^.VType:= varError;

после этого переменную OptionalParam можно передавать вместо неиспользуемого аргумента.

Далее, самый приятный способ получения Result sets:

Там есть масса вариантов, но как выяснилось оптимальным является следующий вариант, который позволяет получить любой желаемый вид курсора (как клиентский, так и серверный)

var

MyConn: _Connection;

MyComm: _Command;

MyRecSet: _Recordset;

prm1: _Parameter;

begin

MyConn:= CoConnection.Create;

MyConn.ConnectionString:= 'DSN=pubs;uid=sa;pwd=;'; MyConn.Open ('', '', '', −1);

MyCommand:= CoCommand.Create;

MyCommand.ActiveConnection:= MyConn;

MyCommand.CommandText:= 'SELECT * FROM blahblah WHERE BlahID=?'

Prm1:= MyCommand.CreateParameter ('Id', adInteger.adParamInput, −1, );

MyCommand.AppendParameter (Prm1);

MyRecSet:= CoRecordSet.Create;

MyRecSet.Open (MyCommand, OptionalParam, adOpenDynamic, adLockReadOnly, adCmdText);

… теперь можно фетчить записи. Работает шустро и классно. Меня радует. Особенно радуют серверные курсоры.

Проверялось на Delphi 3.02 ADO 1.5 MS SQL 6.5 sp4. Пашет как зверь.

Из вкусностей ADO — их легко можно использовать во всяких многопоточных приложениях, где BDE порой сбоит, если, конечно, ODBC драйвер грамотно сделан…

Ну и еще можно использовать для доступа к данным всяких там «нестандартных» баз типа MS Index Server или MS Active Directory Services.

В Delphi (как минимум в 4 версии) существует «константа» EmptyParam, которую можно подставлять в качестве пустого параметра.

{/codecitation}

{codecitation class="brush: pascal; gutter: false;" width="600px"}

Автор: Vit

WEB-сайт: http://forum.vingrad.ru

В оконных приложениях инициализацию COM берет на себя строка в файле проекта:

Application.Initialize;

А вот в DLL и консольных программах обэекта Application нет, и при попытке работать с любыми ActiveX, включая широко используемые ADO компоненты генерится ошибка, которую исправить очень просто: достаточно в секцию Uses в DPR файле добавить модуль oleauto

{/codecitation}

{codecitation class="brush: pascal; gutter: false;" width="600px"}

Автор: http://www.swissdelphicenter.ch

uses

ComObj;

function OpenConnection (ConnectionString: AnsiString): Integer;

var

ADODBConnection: OleVariant;

begin

ADODBConnection:= CreateOleObject ('ADODB.Connection');

ADODBConnection.CursorLocation:= 3; // User client

ADODBConnection.ConnectionString:= ConnectionString;

Result:= 0;

try

ADODBConnection.Open;

except

Result:= −1;

end;

end;

function DataBaseConnection_Test (bMessage: Boolean): AnsiString;

var

asTimeout, asUserName, asPassword, asDataSource, ConnectionString: AnsiString;

iReturn: Integer;

OldCursor: TCursor;

begin

OldCursor:= Screen.Cursor;

Screen.Cursor:= crHourGlass;

asTimeout:= '150';

asUserName:= 'NT_Server';

asPassword:= 'SA';

asDataSource:= 'SQL Server — My DataBase';

ConnectionString:= 'Data Source = ' asDataSource

'User ID = ' asUserName

'Password = ' asPassword

'Mode = Read|Write;Connect Timeout = ' asTimeout;

try

iReturn:= OpenConnection (ConnectionString);

if (bMessage) then

begin

if (iReturn = 0) then

Application.MessageBox ('Connection OK!', 'Information', MB_OK)

else if (iReturn = −1) then

Application.MessageBox ('Connection Error!', 'Error', MB_ICONERROR

MB_OK);

end;

if (iReturn = 0) then

Result:= ConnectionString

else if (iReturn = −1) then

Result:= '';

finally

Screen.Cursor:= OldCursor;

end;

end;

procedure TForm1.Button1Click (Sender: TObject);

begin

DataBaseConnection_Test (True);

end;

{/codecitation}

{codecitation class="brush: pascal; gutter: false;" width="600px"}

Оформил: DeeCo

Автор: Горкуша Алексей

Здесь представлены работающие компоненты обновления данных, полученных запросом через TADOQuery, аналогичные компонентам BDE TQuery,TUpdateSQL

Компоненты TADOUpdateQuery, TADOUpdateSQL выполняют в точности те же функции что и компоненты BDE TQuery,TUpdateSQL.

Это может способствовать быстрому переводу программ с BDE на ADO. Компоненты работающие (в исходных текстах есть комментарии), но до полной совместимости необходимы доработки, например: отсутствуют события onUpdateRecord, onUpdateError.

Предлагаю всем подключится и довести дело до конца.

procedure TForm1.Button1Click (Sender: TObject);

begin

PowerControl1.Action:= actCDEject; // Или…

actLogOFF, actShutDown…PowerControl1.Execute;

end;

= = = = = = = = = = = = = = = = = = = = = = = = = Component Code: unit

PowerControl;

interface uses WinTypes, WinProcs, Messages,

SysUtils, Classes, Controls, Forms, Graphics,

MMSystem;

type

TAction =

(actLogOFF, actShutDown, actReBoot, actForce, actPowerOFF,

actForceIfHung, actMonitorOFF, actMonitorON, actCDEject, actCDUnEject);

type

TPowerControl = class (TComponent)

private

FAction: TAction;

procedure

SetAction (Value: TAction);

protected

public

function Execute:

Boolean;

published

property Action:

TAction read FAction write SetAction;

end;

procedure Register;

implementation

procedure register;

begin

RegisterComponents ('K2', [TPowerControl]);

end;

procedure TPowerControl.SetAction (Value: TAction);

begin

FAction:= Value;

end;

function TPowerControl.Execute: Boolean;

begin

with (Owner as TForm) do

case FAction of

actLogOff:

ExitWindowsEx (EWX_LOGOFF, 1);

actShutDown:

ExitWindowsEx (EWX_SHUTDOWN, 1);

actReBoot:

ExitWindowsEx (EWX_REBOOT, 1);

actForce:

ExitWindowsEx (EWX_FORCE, 1);

actPowerOff:

ExitWindowsEx (EWX_POWEROFF, 1);

actForceIfHung:

ExitWindowsEx (EWX_FORCEIFHUNG, 1);

actMonitorOFF:

SendMessage (Application.Handle,

WM_SYSCOMMAND,

SC_MONITORPOWER, 0);

actMonitorON: SendMessage (Application.Handle, WM_SYSCOMMAND,

SC_MONITORPOWER, −1);

actCDEject: mciSendstring ('SET CDAUDIO DOOR OPEN WAIT', nil, 0, Handle);

actCDUnEject: mciSendstring ('SET CDAUDIO DOOR CLOSED WAIT', nil, 0,

Handle);

end; {Case}

Result:= True;

end;

end.

Скачать ADOComponent.zip (5.7 K)

{/codecitation}