diff options
| author | George Hazan <george.hazan@gmail.com> | 2012-10-09 18:48:50 +0000 |
|---|---|---|
| committer | George Hazan <george.hazan@gmail.com> | 2012-10-09 18:48:50 +0000 |
| commit | 99f1c859eea7d70884d1ad8fa12b061f7b3f8b04 (patch) | |
| tree | 880e846a64fae911277470fb687e5bbabb6ea753 /plugins/Libs/KOLEdb.pas | |
| parent | 29bfa289893d945bc680d52623f8bf1ccfa3a515 (diff) | |
KOL merged with Libs
git-svn-id: http://svn.miranda-ng.org/main/trunk@1849 1316c22d-e87f-b044-9b9b-93d7a3e3ba9c
Diffstat (limited to 'plugins/Libs/KOLEdb.pas')
| -rw-r--r-- | plugins/Libs/KOLEdb.pas | 2209 |
1 files changed, 2209 insertions, 0 deletions
diff --git a/plugins/Libs/KOLEdb.pas b/plugins/Libs/KOLEdb.pas new file mode 100644 index 0000000000..4744adc832 --- /dev/null +++ b/plugins/Libs/KOLEdb.pas @@ -0,0 +1,2209 @@ +unit KOLEdb;
+{* This unit is created for KOL to allow to communicate with DB using OLE DB.
+|<br> ========================================================================
+|<br> Copyright (C) 2001 by Vladimir Kladov.
+|<p>
+ This unit conains three objects TDataSource, TSession and TQuery to implement
+ the most important things: to connect to database, to control transactions,
+ to perform commands (queries) and obtain results or update tables.
+|</p>
+}
+
+interface
+
+uses Windows, ActiveX, KOL, err;
+
+type
+ INT64 = I64;
+ PInt64 = PI64;
+
+ tagVariant = packed Record
+ vt: WORD;
+ reserved1,
+ reserved2,
+ reserved3: WORD;
+ case Integer of
+ 0: ( bVal : Byte );
+ 1: ( iVal : ShortInt );
+ 2: ( lVal : Integer );
+ 3: ( fltVal : Extended );
+ 4: ( dblVal : Double );
+ 5: ( boolVal : Bool );
+ 6: ( scode : SCODE );
+ //7: ( cyVal : CY );
+ //8: ( date : Date );
+ 9: ( bstrVal : Pointer ); // BSTR => [ Len: Integer; array[ 1..Len ] of WideChar ]
+ 10:( pdecVal : ^Decimal );
+ end;
+
+(*
+typedef struct tagVARIANT {
+ VARTYPE vt;
+ unsigned short wReserved1;
+ unsigned short wReserved2;
+ unsigned short wReserved3;
+ union {
+ Byte bVal; // VT_UI1.
+ Short iVal; // VT_I2.
+ long lVal; // VT_I4.
+ float fltVal; // VT_R4.
+ double dblVal; // VT_R8.
+ VARIANT_BOOL boolVal; // VT_BOOL.
+ SCODE scode; // VT_ERROR.
+ CY cyVal; // VT_CY.
+ DATE date; // VT_DATE.
+ BSTR bstrVal; // VT_BSTR.
+ DECIMAL FAR* pdecVal // VT_BYREF|VT_DECIMAL.
+ IUnknown FAR* punkVal; // VT_UNKNOWN.
+ IDispatch FAR* pdispVal; // VT_DISPATCH.
+ SAFEARRAY FAR* parray; // VT_ARRAY|*.
+ Byte FAR* pbVal; // VT_BYREF|VT_UI1.
+ short FAR* piVal; // VT_BYREF|VT_I2.
+ long FAR* plVal; // VT_BYREF|VT_I4.
+ float FAR* pfltVal; // VT_BYREF|VT_R4.
+ double FAR* pdblVal; // VT_BYREF|VT_R8.
+ VARIANT_BOOL FAR* pboolVal; // VT_BYREF|VT_BOOL.
+ SCODE FAR* pscode; // VT_BYREF|VT_ERROR.
+ CY FAR* pcyVal; // VT_BYREF|VT_CY.
+ DATE FAR* pdate; // VT_BYREF|VT_DATE.
+ BSTR FAR* pbstrVal; // VT_BYREF|VT_BSTR.
+ IUnknown FAR* FAR* ppunkVal; // VT_BYREF|VT_UNKNOWN.
+ IDispatch FAR* FAR* ppdispVal; // VT_BYREF|VT_DISPATCH.
+ SAFEARRAY FAR* FAR* pparray; // VT_ARRAY|*.
+ VARIANT FAR* pvarVal; // VT_BYREF|VT_VARIANT.
+ void FAR* byref; // Generic ByRef.
+ char cVal; // VT_I1.
+ unsigned short uiVal; // VT_UI2.
+ unsigned long ulVal; // VT_UI4.
+ int intVal; // VT_INT.
+ unsigned int uintVal; // VT_UINT.
+ char FAR * pcVal; // VT_BYREF|VT_I1.
+ unsigned short FAR * puiVal; // VT_BYREF|VT_UI2.
+ unsigned long FAR * pulVal; // VT_BYREF|VT_UI4.
+ int FAR * pintVal; // VT_BYREF|VT_INT.
+ unsigned int FAR * puintVal; //VT_BYREF|VT_UINT.
+ };
+};
+*)
+
+{============= This part of code is grabbed from OLEDB.pas ================}
+const
+ MAXBOUND = 65535; { High bound for arrays }
+ DBSTATUS_S_ISNULL = $00000003;
+
+type
+ PIUnknown = ^IUnknown;
+ PUintArray = ^TUintArray;
+ TUintArray = array[0..MAXBOUND] of UINT;
+
+ HROW = UINT;
+ PHROW = ^HROW;
+ PPHROW = ^PHROW;
+
+ HACCESSOR = UINT;
+ HCHAPTER = UINT;
+ DBCOLUMNFLAGS = UINT;
+ DBTYPE = Word;
+ DBKIND = UINT;
+ DBPART = UINT;
+ DBMEMOWNER = UINT;
+ DBPARAMIO = UINT;
+ DBBINDSTATUS = UINT;
+
+const
+ IID_NULL : TGUID = '{00000000-0000-0000-0000-000000000000}';
+ IID_IDataInitialize : TGUID = '{2206CCB1-19C1-11D1-89E0-00C04FD7A829}';
+ CLSID_MSDAINITIALIZE: TGUID = '{2206CDB0-19C1-11D1-89E0-00C04FD7A829}';
+
+ IID_IDBInitialize : TGUID = '{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}';
+ //IID_IDBProperties : TGUID = '{0C733A8A-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IDBCreateSession: TGUID = '{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IDBCreateCommand: TGUID = '{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_ICommand : TGUID = '{0C733A63-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_ICommandText : TGUID = '{0C733A27-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_ICommandProperties: TGUID = '{0C733A79-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IRowset : TGUID = '{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IRowsetChange : TGUID = '{0C733A05-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IRowsetUpdate : TGUID = '{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IColumnsInfo : TGUID = '{0C733A11-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_IAccessor : TGUID = '{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}';
+
+ // Added By ECM !!! ==================================================
+ IID_ITransaction : TGUID = '{0FB15084-AF41-11CE-BD2B-204C4F4F5020}';
+ IID_ITransactionLocal: TGUID = '{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}';
+ IID_ITransactionOptions: TGUID = '{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}';
+ // ===================================================================
+
+ // for version 1.5 of OLE DB:
+ //DBGUID_DBSQL : TGUID = '{c8b522df-5cf3-11ce-ade5-00aa0044773d}';
+
+ // otherwise:
+ DBGUID_DBSQL : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}';
+ DBGUID_DEFAULT : TGUID = '{C8B521FB-5CF3-11CE-ADE5-00AA0044773D}';
+ DBGUID_SQL : TGUID = '{C8B522D7-5CF3-11CE-ADE5-00AA0044773D}';
+
+ DBPROPSET_ROWSET : TGUID = '{C8B522BE-5CF3-11CE-ADE5-00AA0044773D}';
+
+ DB_S_ENDOFROWSET = $00040EC6;
+
+type
+
+// *********************************************************************//
+// Interface: IDBInitialize
+// GUID: {0C733A8B-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IDBInitialize = interface(IUnknown)
+ ['{0C733A8B-2A1C-11CE-ADE5-00AA0044773D}']
+ function Initialize: HResult; stdcall;
+ function Uninitialize: HResult; stdcall;
+ end;
+
+// *********************************************************************//
+// Interface: IDBCreateCommand
+// GUID: {0C733A1D-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IDBCreateCommand = interface(IUnknown)
+ ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}']
+ function CreateCommand(const punkOuter: IUnknown; const riid: TGUID;
+ out ppCommand: IUnknown): HResult; stdcall;
+ end;
+
+ (*---
+ { Safecall Version }
+ IDBCreateCommandSC = interface(IUnknown)
+ ['{0C733A1D-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure CreateCommand(const punkOuter: IUnknown; const riid: TGUID;
+ out ppCommand: IUnknown); safecall;
+ end;
+ ---*)
+
+// *********************************************************************//
+// Interface: IDBCreateSession
+// GUID: {0C733A5D-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IDBCreateSession = interface(IUnknown)
+ ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}']
+ function CreateSession(const punkOuter: IUnknown; const riid: TGUID;
+ out ppDBSession: IUnknown): HResult; stdcall;
+ end;
+
+ (*---
+ { Safecall Version }
+ IDBCreateSessionSC = interface(IUnknown)
+ ['{0C733A5D-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure CreateSession(const punkOuter: IUnknown; const riid: TGUID;
+ out ppDBSession: IUnknown); safecall;
+ end;
+ ---*)
+
+// *********************************************************************//
+// Interface: IDataInitialize
+// GUID: {2206CCB1-19C1-11D1-89E0-00C04FD7A829}
+// *********************************************************************//
+ IDataInitialize = interface(IUnknown)
+ ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}']
+ function GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD;
+ pwszInitializationString: POleStr; const riid: TIID;
+ var DataSource: IUnknown): HResult; stdcall;
+ function GetInitializationString(const DataSource: IUnknown;
+ fIncludePassword: Boolean; out pwszInitString: POleStr): HResult; stdcall;
+ function CreateDBInstance(const clsidProvider: TGUID;
+ const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr;
+ riid: TIID; var DataSource: IUnknown): HResult; stdcall;
+ function CreateDBInstanceEx(const clsidProvider: TGUID;
+ const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr;
+ pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI): HResult; stdcall;
+ function LoadStringFromStorage(pwszFileName: POleStr;
+ out pwszInitializationString: POleStr): HResult; stdcall;
+ function WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr;
+ dwCreationDisposition: DWORD): HResult; stdcall;
+ end;
+
+ (*---
+ { Safecall Version }
+ IDataInitializeSC = interface(IUnknown)
+ ['{2206CCB1-19C1-11D1-89E0-00C04FD7A829}']
+ procedure GetDataSource(const pUnkOuter: IUnknown; dwClsCtx: DWORD;
+ pwszInitializationString: POleStr; const riid: TIID;
+ var DataSource: IUnknown); safecall;
+ procedure GetInitializationString(const DataSource: IUnknown;
+ fIncludePassword: Boolean; out pwszInitString: POleStr); safecall;
+ procedure CreateDBInstance(const clsidProvider: TGUID;
+ const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr;
+ riid: TIID; var DataSource: IUnknown); safecall;
+ procedure CreateDBInstanceEx(const clsidProvider: TGUID;
+ const pUnkOuter: IUnknown; dwClsCtx: DWORD; pwszReserved: POleStr;
+ pServerInfo: PCoServerInfo; cmq: ULONG; rgmqResults: PMultiQI); safecall;
+ procedure LoadStringFromStorage(pwszFileName: POleStr;
+ out pwszInitializationString: POleStr); safecall;
+ procedure WriteStringToStorage(pwszFileName, pwszInitializationString: POleStr;
+ dwCreationDisposition: DWORD); safecall;
+ end;
+ ---*)
+
+// *********************************************************************//
+// Interface: ICommand
+// GUID: {0C733A63-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ ICommand = interface(IUnknown)
+ ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}']
+ function Cancel: HResult; stdcall;
+ function Execute(const punkOuter: IUnknown; const riid: TGUID;
+ pParams: Pointer; // var pParams: DBPARAMS;
+ pcRowsAffected: PInteger; ppRowset: PIUnknown): HResult; stdcall;
+ function GetDBSession(const riid: TGUID; out ppSession: IUnknown): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ ICommandSC = interface(IUnknown)
+ ['{0C733A63-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure Cancel; safecall;
+ procedure Execute(const punkOuter: IUnknown; const riid: TGUID; var pParams: DBPARAMS;
+ pcRowsAffected: PInteger; ppRowset: PIUnknown); safecall;
+ procedure GetDBSession(const riid: TGUID; out ppSession: IUnknown); safecall;
+ end;
+ *)
+
+// *********************************************************************//
+// Interface: ICommandText
+// GUID: {0C733A27-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ ICommandText = interface(ICommand)
+ ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}']
+ function GetCommandText(var pguidDialect: TGUID;
+ out ppwszCommand: PWideChar): HResult; stdcall;
+ function SetCommandText(rguidDialect: PGUID;
+ pwszCommand: PWideChar): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ ICommandTextSC = interface(ICommand)
+ ['{0C733A27-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure GetCommandText(var pguidDialect: TGUID;
+ out ppwszCommand: PWideChar); safecall;
+ procedure SetCommandText(rguidDialect: PGUID;
+ pwszCommand: PWideChar); safecall;
+ end;
+ *)
+
+// *********************************************************************//
+// Interface: IRowset
+// GUID: {0C733A7C-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IRowset = interface(IUnknown)
+ ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}']
+ function AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray;
+ rgRowStatus: PUintArray): HResult; stdcall;
+ function GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall;
+ function GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer;
+ out pcRowsObtained: UINT; {var prghRows: PUintArray} prghRows: Pointer ): HResult; stdcall;
+ function ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions,
+ rgRefCounts, rgRowStatus: PUintArray): HResult; stdcall;
+ function RestartPosition(hReserved: HCHAPTER): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ IRowsetSC = interface(IUnknown)
+ ['{0C733A7C-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure AddRefRows(cRows: UINT; rghRows: PUintArray; rgRefCounts: PUintArray;
+ rgRowStatus: PUintArray); safecall;
+ procedure GetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall;
+ procedure GetNextRows(hReserved: HCHAPTER; lRowsOffset: Integer; cRows: Integer;
+ out pcRowsObtained: UINT; var prghRows: PUintArray); safecall;
+ procedure ReleaseRows(cRows: UINT; rghRows: PUintArray; rgRowOptions,
+ rgRefCounts, rgRowStatus: PUintArray); safecall;
+ procedure RestartPosition(hReserved: HCHAPTER); safecall;
+ end;
+ *)
+
+// *********************************************************************//
+// Interface: IRowsetChange
+// GUID: {0C733A05-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IRowsetChange = interface(IUnknown)
+ ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}']
+ function DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray;
+ rgRowStatus: PUintArray): HResult; stdcall;
+ function SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall;
+ function InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer;
+ phRow: PHROW): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ IRowsetChangeSC = interface(IUnknown)
+ ['{0C733A05-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure DeleteRows(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray;
+ rgRowStatus: PUintArray); safecall;
+ procedure SetData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall;
+ procedure InsertRow(hReserved: HCHAPTER; HACCESSOR: HACCESSOR; pData: Pointer;
+ phRow: PHROW); safecall;
+ end;
+ *)
+
+// *********************************************************************//
+// Interface: IRowsetUpdate
+// GUID: {0C733A6D-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ DBPENDINGSTATUS = DWORD;
+ PDBPENDINGSTATUS = ^DBPENDINGSTATUS;
+ PPDBPENDINGSTATUS = ^PDBPENDINGSTATUS;
+
+ DBROWSTATUS = UINT;
+ PDBROWSTATUS = ^DBROWSTATUS;
+ PPDBROWSTATUS = ^PDBROWSTATUS;
+
+ IRowsetUpdate = interface(IRowsetChange)
+ ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}']
+ function GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer): HResult; stdcall;
+ function GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT;
+ prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS): HResult; stdcall;
+ function GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray;
+ rgPendingStatus: PUintArray): HResult; stdcall;
+ function Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT;
+ prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall;
+ function Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT;
+ prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ IRowsetUpdateSC = interface(IRowsetChange)
+ ['{0C733A6D-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure GetOriginalData(HROW: HROW; HACCESSOR: HACCESSOR; pData: Pointer); safecall;
+ procedure GetPendingRows(hReserved: HCHAPTER; dwRowStatus: DBPENDINGSTATUS; pcPendingRows: PUINT;
+ prgPendingRows: PPHROW; prgPendingStatus: PPDBPENDINGSTATUS); safecall;
+ procedure GetRowStatus(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray;
+ rgPendingStatus: PUintArray); safecall;
+ procedure Undo(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRowsUndone: PUINT;
+ prgRowsUndone: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall;
+ procedure Update(hReserved: HCHAPTER; cRows: UINT; rghRows: PUintArray; pcRows: PUINT;
+ prgRows: PPHROW; prgRowStatus: PPDBROWSTATUS); safecall;
+ end;
+ *)
+
+// *********************************************************************//
+// Interface: ICommandProperties
+// GUID: {0C733A79-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+
+ DBPROPID = UINT;
+ PDBPROPID = ^DBPROPID;
+ PDBPropIDArray = ^TDBPropIDArray;
+ TDBPropIDArray = array[0..MAXBOUND] of DBPROPID;
+
+ PDBIDGuid = ^TDBIDGuid;
+ DBIDGUID = record
+ case Integer of
+ 0: (guid: TGUID);
+ 1: (pguid: ^TGUID);
+ end;
+ TDBIDGuid = DBIDGUID;
+
+ PDBIDName = ^TDBIDName;
+ DBIDNAME = record
+ case Integer of
+ 0: (pwszName: PWideChar);
+ 1: (ulPropid: UINT);
+ end;
+ TDBIDName = DBIDNAME;
+
+ DBPROPOPTIONS = UINT;
+ DBPROPSTATUS = UINT;
+ PPDBID = ^PDBID;
+ PDBID = ^DBID;
+ DBID = packed record
+ uGuid: DBIDGUID;
+ eKind: DBKIND;
+ uName: DBIDNAME;
+ end;
+ TDBID = DBID;
+
+ PDBProp = ^TDBProp;
+ DBPROP = packed record
+ dwPropertyID: DBPROPID;
+ dwOptions: DBPROPOPTIONS;
+ dwStatus: DBPROPSTATUS;
+ colid: DBID;
+ vValue: tagVariant; // OleVariant;
+ end;
+ TDBProp = DBPROP;
+
+ PDBPropArray = ^TDBPropArray;
+ TDBPropArray = array[0..MAXBOUND] of TDBProp;
+
+ PPDBPropSet = ^PDBPropSet;
+ PDBPropSet = ^TDBPropSet;
+ DBPROPSET = packed record
+ rgProperties: PDBPropArray;
+ cProperties: UINT;
+ guidPropertySet: TGUID;
+ end;
+ TDBPropSet = DBPROPSET;
+
+ PDBPropIDSet = ^TDBPropIDSet;
+ DBPROPIDSET = packed record
+ rgPropertyIDs: PDBPropIDArray;
+ cPropertyIDs: UINT;
+ guidPropertySet: TGUID;
+ end;
+ TDBPropIDSet = DBPROPIDSET;
+
+ PDBPropIDSetArray = ^TDBPropIDSetArray;
+ TDBPropIDSetArray = array[0..MAXBOUND] of TDBPropIDSet;
+
+ PDBPropSetArray = ^TDBPropSetArray;
+ TDBPropSetArray = array[0..MAXBOUND] of TDBPropSet;
+
+ ICommandProperties = interface(IUnknown)
+ ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}']
+ function GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray;
+ var pcPropertySets: UINT; out prgPropertySets: PDBPropSet): HResult; stdcall;
+ function SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ ICommandPropertiesSC = interface(IUnknown)
+ ['{0C733A79-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure GetProperties(cPropertyIDSets: UINT; rgPropertyIDSets: PDBPropIDSetArray;
+ var pcPropertySets: UINT; out prgPropertySets: PDBPropSet); safecall;
+ procedure SetProperties(cPropertySets: UINT; rgPropertySets: PDBPropSetArray); safecall;
+ end;
+ *)
+
+ PDBIDArray = ^TDBIDArray;
+ TDBIDArray = array[0..MAXBOUND] of TDBID;
+
+ PDBColumnInfo = ^TDBColumnInfo;
+ DBCOLUMNINFO = packed record
+ pwszName: PWideChar;
+ pTypeInfo: ITypeInfo;
+ iOrdinal: UINT;
+ dwFlags: DBCOLUMNFLAGS;
+ ulColumnSize: UINT;
+ wType: DBTYPE;
+ bPrecision: Byte;
+ bScale: Byte;
+ columnid: DBID;
+ end;
+ TDBColumnInfo = DBCOLUMNINFO;
+
+ PColumnInfo = ^TColumnInfoArray;
+ TColumnInfoArray = array[ 0..MAXBOUND ] of TDBColumnInfo;
+
+// *********************************************************************//
+// Interface: IColumnsInfo
+// GUID: {0C733A11-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IColumnsInfo = interface(IUnknown)
+ ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}']
+ function GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo;
+ out ppStringsBuffer: PWideChar): HResult; stdcall;
+ function MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray;
+ rgColumns: PUintArray): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ IColumnsInfoSC = interface(IUnknown)
+ ['{0C733A11-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure GetColumnInfo(var pcColumns: UINT; out prgInfo: PDBColumnInfo;
+ out ppStringsBuffer: PWideChar); safecall;
+ procedure MapColumnIDs(cColumnIDs: UINT; rgColumnIDs: PDBIDArray;
+ rgColumns: PUINTArray); safecall;
+ end;
+ *)
+
+ PDBBindExt = ^TDBBindExt;
+ DBBINDEXT = packed record
+ pExtension: PByte;
+ ulExtension: UINT;
+ end;
+ TDBBindExt = DBBINDEXT;
+
+ PDBObject = ^TDBObject;
+ DBOBJECT = packed record
+ dwFlags: UINT;
+ iid: TGUID;
+ end;
+ TDBObject = DBOBJECT;
+
+ PDBBinding = ^TDBBinding;
+ DBBINDING = packed record
+ iOrdinal: UINT;
+ obValue: UINT;
+ obLength: UINT;
+ obStatus: UINT;
+ pTypeInfo: Pointer; //ITypeInfo; (reserved, should be nil)
+ pObject: PDBObject;
+ pBindExt: PDBBindExt;
+ dwPart: DBPART;
+ dwMemOwner: DBMEMOWNER;
+ eParamIO: DBPARAMIO;
+ cbMaxLen: UINT;
+ dwFlags: UINT;
+ wType: DBTYPE;
+ bPrecision: Byte;
+ bScale: Byte;
+ end;
+ TDBBinding = DBBINDING;
+
+ PDBBindingArray = ^TDBBindingArray;
+ TDBBindingArray = array[0..MAXBOUND] of TDBBinding;
+
+const
+ DBTYPE_EMPTY = $00000000;
+ DBTYPE_NULL = $00000001;
+ DBTYPE_I2 = $00000002;
+ DBTYPE_I4 = $00000003;
+ DBTYPE_R4 = $00000004;
+ DBTYPE_R8 = $00000005;
+ DBTYPE_CY = $00000006;
+ DBTYPE_DATE = $00000007;
+ DBTYPE_BSTR = $00000008;
+ DBTYPE_IDISPATCH = $00000009;
+ DBTYPE_ERROR = $0000000A;
+ DBTYPE_BOOL = $0000000B;
+ DBTYPE_VARIANT = $0000000C;
+ DBTYPE_IUNKNOWN = $0000000D;
+ DBTYPE_DECIMAL = $0000000E;
+ DBTYPE_UI1 = $00000011;
+ DBTYPE_ARRAY = $00002000;
+ DBTYPE_BYREF = $00004000;
+ DBTYPE_I1 = $00000010;
+ DBTYPE_UI2 = $00000012;
+ DBTYPE_UI4 = $00000013;
+ DBTYPE_I8 = $00000014;
+ DBTYPE_UI8 = $00000015;
+ DBTYPE_FILETIME = $00000040;
+ DBTYPE_GUID = $00000048;
+ DBTYPE_VECTOR = $00001000;
+ DBTYPE_RESERVED = $00008000;
+ DBTYPE_BYTES = $00000080;
+ DBTYPE_STR = $00000081;
+ DBTYPE_WSTR = $00000082;
+ DBTYPE_NUMERIC = $00000083;
+ DBTYPE_UDT = $00000084;
+ DBTYPE_DBDATE = $00000085;
+ DBTYPE_DBTIME = $00000086;
+ DBTYPE_DBTIMESTAMP = $00000087;
+ DBTYPE_DBFILETIME = $00000089;
+ DBTYPE_PROPVARIANT = $0000008A;
+ DBTYPE_VARNUMERIC = $0000008B;
+
+type
+// *********************************************************************//
+// Interface: IAccessor
+// GUID: {0C733A8C-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ IAccessor = interface(IUnknown)
+ ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}']
+ function AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall;
+ function CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray;
+ cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray): HResult; stdcall;
+ function GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT;
+ out prgBindings: PDBBinding): HResult; stdcall;
+ function ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT): HResult; stdcall;
+ end;
+
+ (*
+ { Safecall Version }
+ IAccessorSC = interface(IUnknown)
+ ['{0C733A8C-2A1C-11CE-ADE5-00AA0044773D}']
+ procedure AddRefAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall;
+ procedure CreateAccessor(dwAccessorFlags: UINT; cBindings: UINT; rgBindings: PDBBindingArray;
+ cbRowSize: UINT; var phAccessor: HACCESSOR; rgStatus: PUintArray); safecall;
+ procedure GetBindings(HACCESSOR: HACCESSOR; pdwAccessorFlags: PUINT; var pcBindings: UINT;
+ out prgBindings: PDBBinding); safecall;
+ procedure ReleaseAccessor(HACCESSOR: HACCESSOR; pcRefCount: PUINT); safecall;
+ end;
+ *)
+
+// Begin Added By ECM !!! =======================================================
+ PBoid = ^TBoid;
+ BOID = packed record
+ rgb_: array[0..15] of Byte;
+ end;
+ TBoid = BOID;
+
+ PXactTransInfo = ^TXactTransInfo;
+ XACTTRANSINFO = packed record
+ uow: BOID;
+ isoLevel: Integer;
+ isoFlags: UINT;
+ grfTCSupported: UINT;
+ grfRMSupported: UINT;
+ grfTCSupportedRetaining: UINT;
+ grfRMSupportedRetaining: UINT;
+ end;
+ TXactTransInfo = XACTTRANSINFO;
+
+ PXactOpt = ^TXactOpt;
+ XACTOPT = packed record
+ ulTimeout: UINT;
+ szDescription: array[0..39] of Shortint;
+ end;
+ TXActOpt = XACTOPT;
+
+// *********************************************************************//
+// Interface: ITransactionOptions
+// GUID: {3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}
+// *********************************************************************//
+ ITransactionOptions = interface(IUnknown)
+ ['{3A6AD9E0-23B9-11CF-AD60-00AA00A74CCD}']
+ function SetOptions(var pOptions: XACTOPT): HResult; stdcall;
+ function GetOptions(var pOptions: XACTOPT): HResult; stdcall;
+ end;
+
+// *********************************************************************//
+// Interface: ITransaction
+// GUID: {0FB15084-AF41-11CE-BD2B-204C4F4F5020}
+// *********************************************************************//
+ ITransaction = interface(IUnknown)
+ ['{0FB15084-AF41-11CE-BD2B-204C4F4F5020}']
+ function Commit(fRetaining: BOOL; grfTC: UINT; grfRM: UINT): HResult; stdcall;
+ function Abort(pboidReason: PBOID; fRetaining: BOOL; fAsync: BOOL): HResult; stdcall;
+ function GetTransactionInfo(out pinfo: XACTTRANSINFO): HResult; stdcall;
+ end;
+
+// *********************************************************************//
+// Interface: ITransactionLocal
+// GUID: {0C733A5F-2A1C-11CE-ADE5-00AA0044773D}
+// *********************************************************************//
+ ITransactionLocal = interface(ITransaction)
+ ['{0C733A5F-2A1C-11CE-ADE5-00AA0044773D}']
+ function GetOptionsObject(out ppOptions: ITransactionOptions): HResult; stdcall;
+ function StartTransaction(isoLevel: Integer; isoFlags: UINT;
+ const pOtherOptions: ITransactionOptions; pulTransactionLevel: PUINT): HResult; stdcall;
+ end;
+
+const
+ XACTTC_SYNC_PHASEONE = $00000001;
+ XACTTC_SYNC_PHASETWO = $00000002;
+ XACTTC_SYNC = $00000002;
+ XACTTC_ASYNC_PHASEONE = $00000004;
+ XACTTC_ASYNC = $00000004;
+
+// End Added By ECM !!! =========================================================
+
+// Begin Added By azsd !!! ======================================================
+(*
+type
+ PDbNumeric = ^tagDB_NUMERIC;
+ tagDB_NUMERIC = packed record
+ precision: Byte;
+ scale: Byte;
+ sign: Byte;
+ val: array[0..15] of Byte;
+ end;
+*)
+// End Added By azsd !!! ========================================================
+
+{============= This part of code is designed by me ================}
+type
+ PDBBINDSTATUSARRAY = ^TDBBINDSTATUSARRAY;
+ TDBBINDSTATUSARRAY = array[ 0..MAXBOUND ] of DBBINDSTATUS;
+
+//''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+// TDataSource - a connection to data base
+//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+type
+ PDataSource = ^TDataSource;
+ TDataSource = object( TObj )
+ {* This object provides a connection with data base. You create it using
+ NewDataSource function and passing a connection string to it. The object
+ is initializing immediately after creating. You can get know if the
+ connection established successfully reading Intitialized property. }
+ private
+ fSessions: PList;
+ fIDBInitialize: IDBInitialize;
+ FInitialized: Boolean;
+ protected
+ function Initialize( const Params: String ): Boolean;
+ public
+ constructor Create;
+ {* Do not call this constructor. Use function NewDataSource instead. }
+ destructor Destroy; virtual;
+ {* Do not call this destructor. Use Free method instead. When TDataSource
+ object is destroyed, all its sessions (and consequensly, all queries)
+ are freed automatically. }
+ property Initialized: Boolean read FInitialized;
+ {* Returns True, if the connection with database is established. Mainly,
+ it is not necessary to analizy this flag. If any error occure during
+ initialization, CheckOle halts further execution. (But You can use
+ another error handler, which does not stop the application). }
+ end;
+
+function NewDataSource( const Params: String ): PDataSource;
+{* Creates data source objects and initializes it. Pass a connection
+ string as a parameter, which determines used provider, database
+ location, user identification and other parameters. See demo provided
+ or/and read spicifications from database software vendors, which
+ parameters to pass. }
+
+//''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+// TSession - transaction session in a connection
+//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+type
+ PSession = ^TSession;
+ TSession = object( TObj )
+ {* This object is intended to provide session transactions. It always
+ must be created as a "child" of TDataSource object, and it owns by
+ query objects (of type TQuery). For each TDataSource object, it is
+ possible to create several TSession objects, and for each session,
+ several TQuery objects can exist. }
+ private
+ fQueryList: PList;
+ fDataSource: PDataSource;
+ fCreateCommand: IDBCreateCommand;
+
+ // Added By ECM !!! ==================
+ fTransaction: ITransaction;
+ fTransactionLocal: ITransactionLocal;
+ // ===================================
+
+ protected
+ public
+ constructor Create;
+ {* }
+ destructor Destroy; virtual;
+ {* Do not call directly, call Free method instead. When TSession object is
+ destroyed, all it child queries are freed automatically. }
+
+ // Added By ECM !!! ====================================
+ function StartTransaction(isoLevel: Integer): HRESULT;
+ function Commit(Retaining: BOOL): HRESULT;
+ function Rollback(Retaining: BOOL): HRESULT;
+ function Active: Boolean;
+ // =====================================================
+
+ property DataSource: PDataSource read fDataSource;
+ {* Returns a pointer to owner TDataSource object. }
+ end;
+
+function NewSession( ADataSource: PDataSource ): PSession;
+{* Creates session object owned by ADataSource (this last must exist). }
+
+//''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
+// TQuery - a command and resulting rowset(s)
+//,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,,
+type
+ TRowsetMode = ( rmUpdateImmediate, rmUpdateDelayed, rmReadOnly );
+ TFieldType = ( ftInteger, ftReal, ftString, ftDate, ftLargeInt, ftOther );
+
+ PQuery = ^TQuery;
+ TQuery = object( TObj )
+ {* This is the most important object to work with database. It is always
+ must be created as a "child" of TSession object, and allows to perform
+ commands, open rowsets, scroll it, update and so on. }
+ private
+ fSession: PSession;
+ fText: String;
+ fCommand: ICommandText;
+ fCommandProps: ICommandProperties;
+ fRowsAffected: Integer;
+ fRowSet: IRowset;
+ fRowSetChg: IRowsetChange;
+ fRowSetUpd: IRowsetUpdate;
+ fColCount: UINT;
+ fColInfo: PColumnInfo;
+ fColNames: PWideChar;
+ fBindings: PDBBindingArray;
+ fBindStatus: PDBBINDSTATUSARRAY;
+ fRowSize: Integer;
+ fAccessor: HACCESSOR;
+ fRowHandle: THandle;
+ fRowBuffers: PList;
+ fEOF: Boolean;
+ fCurIndex: Integer;
+ fChanged: Boolean;
+ fMode: TRowsetMode;
+ procedure SetText(const Value: String);
+ function GetRowCount: Integer;
+ function GetColNames(Idx: Integer): String;
+ procedure SetCurIndex(const Value: Integer);
+ function GetRowsKnown: Integer;
+ function GetStrField(Idx: Integer): String;
+ procedure SetStrField(Idx: Integer; const Value: String);
+ function GetIntField(Idx: Integer): Integer;
+ procedure SetIntField(Idx: Integer; const Value: Integer);
+ function GetFltField(Idx: Integer): Double;
+ procedure SetFltField(Idx: Integer; const Value: Double);
+ function GetDField(Idx: Integer): TDateTime;
+ procedure SetDField(Idx: Integer; const Value: TDateTime);
+ function FieldPtr( Idx: Integer ): Pointer;
+ function Changed( Idx: Integer ): Pointer;
+ function GetColByName(Name: String): Integer;
+ function GetSFieldByName(const Name: String): String;
+ procedure SetSFieldByName(const Name: String; const Value: String);
+ function GetIFieldByName(const Name: String): Integer;
+ procedure SetIFieldByName(const Name: String; Value: Integer);
+ function GetRFieldByName(const Name: String): Double;
+ procedure SetRFieldByName(const Name: String; const Value: Double);
+ function GetDFlfByName(const Name: String): TDateTime;
+ procedure SetDFldByName(const Name: String; const Value: TDateTime);
+ function GetColType(Idx: Integer): TFieldType;
+ function GetColTypeByName(const Name: String): TFieldType;
+ function GetIsNull(Idx: Integer): Boolean;
+ procedure SetIsNull(Idx: Integer; const Value: Boolean);
+ function GetIsNullByName(const Name: String): Boolean;
+ procedure SetIsNullByName(const Name: String; const Value: Boolean);
+ function GetFByNameAsStr(const Name: String): String;
+ function GetFieldAsStr(Idx: Integer): String;
+ procedure SetFByNameFromStr(const Name, Value: String);
+ procedure SetFieldFromStr(Idx: Integer; const Value: String);
+ function GetI64Field(Idx: Integer): Int64;
+ function GetI64FldByName(const Name: String): Int64;
+ procedure SetI64Field(Idx: Integer; const Value: Int64);
+ procedure SetI64FldByName(const Name: String; const Value: Int64);
+ function GetFixupNumeric(Idx: Integer): Int64; //add by azsd
+ function GetRawType(Idx: Integer): DWORD;
+ function GetRawTypeByName(const Name: String): DWORD;
+ function GetFieldAsHex(Idx: Integer): Pointer;
+ function GetFieldByNameAsHex(const Name: String): Pointer;
+ protected
+ fDelList: PList;
+ procedure ClearRowset;
+ procedure ReleaseHandle;
+ procedure FetchData;
+ procedure NextWOFetch( Skip: Integer );
+ public
+ destructor Destroy; virtual;
+ {* Do not call the destructor directly, call method Free instead. When
+ "parent" TSession object is destroyed, all queries owned by the session
+ are destroyed automatically. }
+ property Session: PSession read fSession;
+ {* Returns owner session object. }
+ property Text: String read FText write SetText;
+ {* Query command text. When You change it, currently opened rowset (if any)
+ is closed, so there are no needs to call Close method before preparing
+ for new command. Current version does not support passing "parameters",
+ so include all values into Text as a part of string. }
+ procedure Close;
+ {* Closes opened rowset if any. It is not necessary to call close after
+ Execute. Also, rowset is closed automatically when another value is
+ assigned to Text property. }
+ procedure Execute;
+ {* Call this method to execute command (stored in Text), which does not
+ open a rowset (thus is, "insert", "delete", and "update" SQL statements
+ do so). }
+ procedure Open;
+ {* Call this method for executing command, which opens a rowset (table of
+ data). This can be "select" SQL statement, or call to stored procedure,
+ which returns result in a table. }
+ property RowCount: Integer read GetRowCount;
+ {* For commands, such as "insert", "delete" or "update" SQL statements,
+ this property returns number of rows affected by a command. For "select"
+ statement performed using Open method, this property should return
+ a number of rows selected. By for (the most) providers, this value is
+ unknown for first time (-1 is returned). To get know how much rows are
+ in returned rowset, method Last should be called first. But for large
+ data returned this is not efficient way, because actually a loop
+ "while not EOF do Next" is performed to do so.
+ |<br>
+ Tip: to get count of rows, You can call another query, which executes
+ "select count(*) where..." SQL statement with the same conditions. }
+ property RowsKnown: Integer read GetRowsKnown;
+ {* Returns actual number or selected rows, if this is "known" value, or number
+ of rows already fetched. }
+ property ColCount: UINT read fColCount;
+ {* Returns number of columns in opened rowset. }
+ property ColNames[ Idx: Integer ]: String read GetColNames;
+ {* Return names of columns. }
+ property ColByName[ Name: String ]: Integer read GetColByName;
+ {* Returns column index by name. Comparing of names is ANSI and case insensitive. }
+ property ColType[ Idx: Integer ]: TFieldType read GetColType;
+ {* }
+ property ColTypeByName[ const Name: String ]: TFieldType read GetColTypeByName;
+ {* }
+ function FirstColumn: Integer;
+ {* by Alexander Shakhaylo. To return an index of the first column,
+ containing actual data. (for .mdb, the first can contain special
+ control information, but not for .dbf) }
+ property RawType[ Idx: Integer ]: DWORD read GetRawType;
+ {*}
+ property RawTypeByName[ const Name: String ]: DWORD read GetRawTypeByName;
+ {*}
+ property EOF: Boolean read fEOF;
+ {* Returns True, if end of data is achived (usually after calling Next
+ or Prev method, or immediately after Open, if there are no rows in opened
+ rowset). }
+ procedure First;
+ {* Resets a position to the start of rowset. This method is called
+ automatically when Open is called successfully. }
+ procedure Next;
+ {* Moves position to the next row if possible. If EOF achived, a position
+ is not changed. }
+ procedure Prev;
+ {* Moves position to a previous row (but if CurIndex > 0). }
+ procedure Last;
+ {* Moves position to the last row. This method can be unefficient for
+ large datasets, because implemented as a loop where method Next is
+ called repeteadly, while EOF is not achieved. }
+ property Mode: TRowsetMode read fMode write fMode;
+ {* }
+ procedure Post;
+ {* Applyes changes made in a record, writing changed row to database table. }
+ procedure Delete;
+ {* Deletes a row. In rmUpdateDelayed Mode, rows are only added to a list
+ for later deleting it when Update called. }
+ procedure Update;
+ {* Allows to apply all updates far later, not when Post method is called.
+ To use TQuery in this manner, its Mode should be set to rmUpdateDelayed. }
+ property CurIndex: Integer read fCurIndex write SetCurIndex;
+ {* Index of current row. It is possible to change it directly even if
+ specified row is not yet fetched. But check at least what new value is
+ stored in CurIndex after such assignment. }
+ property SField[ Idx: Integer ]: String read GetStrField write SetStrField;
+ {* Access to a string field by index. You should be sure, that a field
+ has string type. }
+ property SFieldByName[ const Name: String ]: String read GetSFieldByName write SetSFieldByName;
+ {* }
+ property IField[ Idx: Integer ]: Integer read GetIntField write SetIntField;
+ {* Access to a integer field by index. You should be sure, that a field
+ has integer type or compatible. }
+ property IFieldByName[ const Name: String ]: Integer read GetIFieldByName write SetIFieldByName;
+ {* }
+ property LField[ Idx: Integer ]: Int64 read GetI64Field write SetI64Field;
+ {* }
+ property LFieldByName[ const Name: String ]: Int64 read GetI64FldByName write SetI64FldByName;
+ {* }
+ property RField[ Idx: Integer ]: Double read GetFltField write SetFltField;
+ {* Access to a real (Double) field by index. You should be sure, that a field
+ has numeric (with floating decimal point) type. }
+ property RFieldByName[ const Name: String ]: Double read GetRFieldByName write SetRFieldByName;
+ {* }
+ property DField[ Idx: Integer ]: TDateTime read GetDField write SetDField;
+ {* }
+ property DFieldByName[ const Name: String ]: TDateTime read GetDFlfByName write SetDFldByName;
+ {* }
+ property IsNull[ Idx: Integer ]: Boolean read GetIsNull write SetIsNull;
+ {* }
+ property IsNullByName[ const Name: String ]: Boolean read GetIsNullByName write SetIsNullByName;
+ {* }
+ property FieldAsStr[ Idx: Integer ]: String read GetFieldAsStr write SetFieldFromStr;
+ {* }
+ property FieldByNameAsStr[ const Name: String ]: String read GetFByNameAsStr write SetFByNameFromStr;
+ {* }
+ property FieldAsHex[ Idx: Integer ]: Pointer read GetFieldAsHex;
+ {* Access to field data directly. If you change field data inplace, call
+ MarkRecordChanged by yourself. If field IsNull, data found at the address
+ provided have no sense. }
+ property FieldByNameAsHex[ const Name: String ]: Pointer read GetFieldByNameAsHex;
+ {* See FieldByNameAsHex. }
+ procedure MarkFieldChanged( Idx: Integer );
+ {* See also MarkRecordChangedByName. }
+ procedure MarkFieldChangedByName( const Name: String );
+ {* When record field changed directly (using FieldAsHex property, for ex.),
+ use this method to signal to record set container, that record is changed,
+ and to ensure that field no more marked as null. }
+ end;
+
+function NewQuery( Session: PSession ): PQuery;
+{* Creates query object. }
+
+// Error handling routines:
+
+function CheckOLE( Rslt: HResult ): Boolean;
+function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean;
+procedure DummyOleError( Result: HResult );
+var OleError: procedure( Result: HResult ) = DummyOleError;
+
+implementation
+
+type
+ PDBNumeric = ^TDBNumeric;
+ TDBNUMERIC = packed record
+ precision: Byte;
+ scale: Byte;
+ sign: Byte;
+ val: array[0..15] of Byte;
+ end;
+
+ PDBVarNumeric = ^TDBVarNumeric;
+ TDBVARNUMERIC = packed record
+ precision: Byte;
+ scale: ShortInt;
+ sign: Byte;
+ val: ^Byte;
+ end;
+
+ PDBDate = ^TDBDate;
+ TDBDATE = packed record
+ year: Smallint;
+ month: Word;
+ day: Word;
+ end;
+
+ PDBTime = ^TDBTIME;
+ TDBTIME = packed record
+ hour: Word;
+ minute: Word;
+ second: Word;
+ end;
+
+ PDBTimeStamp = ^TDBTimeStamp;
+ TDBTIMESTAMP = packed record
+ year: Smallint;
+ month: Word;
+ day: Word;
+ hour: Word;
+ minute: Word;
+ second: Word;
+ fraction: UINT;
+ end;
+
+var fIMalloc: IMalloc = nil;
+
+(* procedure DummyOleError( Result: HResult );
+begin
+ MsgOK( 'OLE DB error ' + Int2Hex( Result, 8 ) );
+ Halt;
+end; *)
+
+procedure DummyOleError( Result: HResult );
+begin
+ raise Exception.Create( e_Custom, 'OLE DB error ' + Int2Hex( Result, 8 ) );
+end;
+
+function CheckOLE( Rslt: HResult ): Boolean;
+begin
+ Result := Rslt = 0;
+ if not Result then
+ OleError( Rslt );
+end;
+
+function CheckOLEex( Rslt: HResult; const OKResults: array of HResult ): Boolean;
+var I: Integer;
+begin
+ Result := TRUE;
+ for I := Low( OKResults ) to High( OKResults ) do
+ if Rslt = OKResults[ I ] then Exit;
+ Result := FALSE;
+ OleError( Rslt );
+end;
+
+{ TDataSource }
+
+function NewDataSource( const Params: String ): PDataSource;
+begin
+ new( Result, Create );
+ Result.Initialize( Params );
+end;
+
+constructor TDataSource.Create;
+var clsid: TCLSID;
+begin
+ inherited;
+ fSessions := NewList;
+ //if CheckOLEex( CoInitialize( nil ), [ S_OK, S_FALSE ] ) then
+ OleInit;
+ if CheckOLE( CoGetMalloc( MEMCTX_TASK, fIMalloc ) ) then
+ if CheckOLE( CLSIDFromProgID( 'SQLOLEDB', clsid ) ) then
+ CheckOLE( CoCreateInstance( clsid, nil, CLSCTX_INPROC_SERVER,
+ IID_IDBInitialize, fIDBInitialize ) );
+end;
+
+destructor TDataSource.Destroy;
+var I: Integer;
+begin
+ for I := fSessions.Count - 1 downto 0 do
+ PObj( fSessions.Items[ I ] ).Free;
+ fSessions.Free;
+ if Initialized then
+ CheckOLE( fIDBInitialize.UnInitialize );
+ OleUnInit;
+ inherited;
+end;
+
+function TDataSource.Initialize( const Params: String ): Boolean;
+var DI: IDataInitialize;
+ Unk: IUnknown;
+begin
+ Result := FALSE;
+ if Initialized then
+ begin
+ Result := TRUE;
+ Exit;
+ end;
+ if CheckOLE( CoCreateInstance( CLSID_MSDAINITIALIZE, nil,
+ CLSCTX_ALL, IID_IDataInitialize, DI ) ) then
+ if CheckOLE( DI.GetDataSource( nil, CLSCTX_ALL, StringToOleStr( Params ),
+ IID_IDBInitialize, Unk ) ) then
+ if CheckOLE( Unk.QueryInterface( IID_IDBInitialize, fIDBInitialize ) ) then
+ if CheckOLE( fIDBInitialize.Initialize ) then
+ begin
+ Result := TRUE;
+ FInitialized := Result;
+ end;
+end;
+
+{ TSession }
+
+function NewSession( ADataSource: PDataSource ): PSession;
+var CreateSession: IDBCreateSession;
+ Unk: IUnknown;
+begin
+ new( Result, Create );
+ Result.fDataSource := ADataSource;
+ ADataSource.fSessions.Add( Result );
+ // Modified by ECM !!! ===============================================================================
+ if CheckOLE( ADataSource.fIDBInitialize.QueryInterface( IID_IDBCreateSession, CreateSession ) ) then begin
+ CheckOLE( CreateSession.CreateSession( nil, IID_IDBCreateCommand,
+ IUnknown( Result.fCreateCommand ) ) );
+
+ Unk := Result.fCreateCommand;
+ if Assigned(Unk) then begin
+ CheckOLE(Unk.QueryInterface(IID_ITransaction,Result.fTransaction));
+ CheckOLE(Unk.QueryInterface(IID_ITransactionLocal,Result.fTransactionLocal));
+ end;
+ end;
+ // =================================================================================================
+end;
+
+// Added By ECM !!! ==============================================
+function TSession.Active: Boolean;
+var
+ xinfo: TXactTransInfo;
+ Ret: HRESULT;
+begin
+ if not Assigned(fTransaction) then Result := FALSE
+ else begin
+ FillChar(xinfo,SizeOf(xinfo),0);
+ Ret := fTransaction.GetTransactionInfo(xinfo);
+ Result := Ret = S_OK;
+ CheckOLE(Ret);
+ end;
+end;
+
+function TSession.Commit(Retaining: BOOL): HRESULT;
+begin
+ Assert(Assigned(fTransaction));
+ Result := fTransaction.Commit(Retaining,XACTTC_SYNC,0);
+ CheckOLE(Result);
+end;
+// ===============================================================
+
+constructor TSession.Create;
+begin
+ inherited;
+ fQueryList := NewList;
+end;
+
+destructor TSession.Destroy;
+var I: Integer;
+begin
+ for I := fQueryList.Count - 1 downto 0 do
+ PObj( fQueryList.Items[ I ] ).Free;
+ fQueryList.Free;
+ I := fDataSource.fSessions.IndexOf( @Self );
+ fDataSource.fSessions.Delete( I );
+ // Add By ECM !!! ================
+ // if Active then Rollback(FALSE);
+ //================================
+ fCreateCommand := nil;
+ inherited;
+end;
+
+// Added By ECM !!! ===============================================
+function TSession.Rollback(Retaining: BOOL): HRESULT;
+begin
+ Assert(Assigned(fTransaction));
+ Result := fTransaction.Abort(nil,Retaining,FALSE);
+ CheckOLE(Result);
+end;
+
+function TSession.StartTransaction(isoLevel: Integer): HRESULT;
+begin
+ Assert(Assigned(fTransactionLocal));
+ Result := fTransactionLocal.StartTransaction(isoLevel,0,nil,nil);
+ CheckOLE(Result);
+end;
+// ================================================================
+
+{ TQuery }
+
+function NewQuery( Session: PSession ): PQuery;
+begin
+ new( Result, Create );
+ Result.fSession := Session;
+ Session.fQueryList.Add( Result );
+ CheckOLE( Session.fCreateCommand.CreateCommand( nil, IID_ICommandText,
+ IUnknown( Result.fCommand ) ) );
+end;
+
+function TQuery.Changed( Idx: Integer ): Pointer;
+begin
+ fChanged := TRUE;
+ Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) +
+ fBindings[ Idx ].obStatus );
+ PDWORD( Result )^ := 0; // set to NOT NULL
+end;
+
+procedure TQuery.ClearRowset;
+var I: Integer;
+ AccessorIntf: IAccessor;
+begin
+ ReleaseHandle;
+
+ if fAccessor <> 0 then
+ begin
+ if CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) ) then
+ AccessorIntf.ReleaseAccessor( fAccessor, nil );
+ fAccessor := 0;
+ end;
+
+ if fRowBuffers <> nil then
+ begin
+ for I := fRowBuffers.Count - 1 downto 0 do
+ FreeMem( fRowBuffers.Items[ I ] );
+ fRowBuffers.Free;
+ fRowBuffers := nil;
+ end;
+ fRowSize := 0;
+
+ if fBindings <> nil then
+ begin
+ //for I := 0 to fColCount - 1 do
+ // fBindings[ I ].pTypeInfo := nil;
+ FreeMem( fBindings );
+ fBindings := nil;
+ FreeMem( fBindStatus );
+ fBindStatus := nil;
+ end;
+
+ if fColInfo <> nil then
+ fIMalloc.Free( fColInfo );
+ fColInfo := nil;
+
+ if fColNames <> nil then
+ fIMalloc.Free( fColNames );
+ fColNames := nil;
+
+ fColCount := 0;
+ fRowSetUpd := nil;
+ fRowSet := nil;
+ fRowSetChg := nil;
+ fRowsAffected := 0;
+
+ fEOF := TRUE;
+end;
+
+procedure TQuery.Close;
+begin
+ Update;
+ ClearRowset;
+end;
+
+procedure TQuery.Delete;
+var Params, Results: array of DWORD;
+begin
+ //if fRowHandle = 0 then Exit;
+ CASE fMode OF
+ rmUpdateImmediate:
+ begin
+ SetLength( Results, 1 );
+ SetLength( Params, 1 );
+ Params[ 0 ] := fRowHandle;
+ CheckOLE( fRowSetUpd.DeleteRows( 0, 1, @ Params[ 0 ], @ Results[ 0 ] ) );
+ end;
+ rmUpdateDelayed:
+ begin
+ if fDelList = nil then
+ fDelList := NewList;
+ fDelList.Add( Pointer( fRowHandle ) );
+ end;
+ END;
+end;
+
+destructor TQuery.Destroy;
+var I: Integer;
+begin
+ Close; //ClearRowset;
+ I := fSession.fQueryList.IndexOf( @Self );
+ if I >= 0 then
+ fSession.fQueryList.Delete( I );
+ fText := '';
+ fCommandProps := nil;
+ fCommand := nil;
+ fDelList.Free;
+ inherited;
+end;
+
+procedure TQuery.Execute;
+begin
+ ClearRowset;
+ // first set txt to fCommand just before execute
+ if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then
+ CheckOLE( fCommand.Execute( nil, IID_NULL, nil, @fRowsAffected, nil ) );
+end;
+
+procedure TQuery.FetchData;
+var Buffer: Pointer;
+begin
+ if fRowHandle = 0 then
+ Exit;
+ if fRowBuffers.Items[ fCurIndex ] = nil then
+ begin
+ GetMem( Buffer, fRowSize );
+ FillChar( Buffer^, fRowSize, 0 ); //fixup the varnumberic random bytes by azsd
+ fRowBuffers.Items[ fCurIndex ] := Buffer;
+ CheckOLE( fRowSet.GetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] ) );
+ end;
+end;
+
+function TQuery.FieldPtr(Idx: Integer): Pointer;
+begin
+ if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then
+ Result := nil
+ else
+ Result := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) +
+ fBindings[ Idx ].obValue );
+end;
+
+procedure TQuery.First;
+begin
+ if fCurIndex = 0 then Exit;
+ ReleaseHandle;
+ fCurIndex := -1;
+ if CheckOLE( fRowSet.RestartPosition( 0 ) ) then
+ begin
+ fEOF := FALSE;
+ Next;
+ end;
+end;
+
+function TQuery.FirstColumn: Integer;
+var i: integer;
+begin
+ Result := -1;
+ for i := 0 to fColCount - 1 do begin
+ if fBindings[i].iOrdinal > 0 then begin
+ Result := i;
+ exit;
+ end;
+ end;
+end;
+
+function TQuery.GetColByName(Name: String): Integer;
+var I: Integer;
+begin
+ Result := -1;
+ for I := 0 to fColCount - 1 do
+ begin
+ if AnsiCompareStrNoCase( Name, ColNames[ I ] ) = 0 then
+ begin
+ Result := I;
+ break;
+ end;
+ end;
+end;
+
+function TQuery.GetColNames(Idx: Integer): String;
+begin
+ Result := fColInfo[ Idx ].pwszName;
+end;
+
+function TQuery.GetColType(Idx: Integer): TFieldType;
+begin
+ Result := ftOther;
+ if fBindings = nil then Exit;
+ case fBindings[ Idx ].wType of
+ DBTYPE_I1, DBTYPE_I2, DBTYPE_I4, DBTYPE_BOOL,
+ DBTYPE_UI1, DBTYPE_UI2, DBTYPE_UI4 : Result := ftInteger;
+ DBTYPE_I8, DBTYPE_UI8 : Result := ftLargeInt;
+ DBTYPE_BSTR, DBTYPE_WSTR, DBTYPE_STR: Result := ftString;
+ DBTYPE_R4, DBTYPE_R8, DBTYPE_CY,
+ DBTYPE_NUMERIC, DBTYPE_VARNUMERIC,
+ DBTYPE_DECIMAL : Result := ftReal;// no need new cate here,moved to GetFieldAsStr
+ DBTYPE_DATE, DBTYPE_FILETIME, //DBTYPE_DBFILETIME,
+ DBTYPE_DBDATE, DBTYPE_DBTIME,
+ DBTYPE_DBTIMESTAMP : Result := ftDate;
+ else Result := ftOther;
+ end;
+end;
+
+function TQuery.GetColTypeByName(const Name: String): TFieldType;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >= 0, 'Incorrect column name (' + Name + ').' );
+ Result := ColType[ Idx ];
+end;
+
+function TQuery.GetDField(Idx: Integer): TDateTime;
+var P: Pointer;
+ ST: TSystemTime;
+ pD: PDBDate;
+ pT: PDBTime;
+ TS: PDBTimeStamp;
+ pFT: PFileTime;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Result := 0.0
+ else
+ begin
+ FillChar( ST, Sizeof(ST), 0 );
+ case fBindings[ Idx ].wType of
+ DBTYPE_DATE: Result := PDouble( P )^ + VCLDate0;
+ DBTYPE_DBDATE:
+ begin
+ pD := P;
+ ST.wYear := pD.year;
+ ST.wMonth := pD.month;
+ ST.wDay := pD.day;
+ SystemTime2DateTime( ST, Result );
+ end;
+ DBTYPE_DBTIME:
+ begin
+ pT := P;
+ ST.wYear := 1899;
+ ST.wMonth := 12;
+ ST.wDay := 31;
+ ST.wHour := pT.hour;
+ ST.wMinute := pT.minute;
+ ST.wSecond := pT.second;
+ SystemTime2DateTime( ST, Result );
+ Result := Result - VCLDate0;
+ end;
+ DBTYPE_DBTIMESTAMP:
+ begin
+ TS := P;
+ ST.wYear := TS.year;
+ ST.wMonth := TS.month;
+ ST.wDay := TS.day;
+ ST.wHour := TS.hour;
+ ST.wMinute := TS.minute;
+ ST.wSecond := TS.second;
+ ST.wMilliseconds := TS.fraction div 1000000;
+ SystemTime2DateTime( ST, Result );
+ end;
+ DBTYPE_FILETIME:
+ begin
+ pFT := P;
+ FileTimeToSystemTime( pFT^, ST );
+ SystemTime2DateTime( ST, Result );
+ end;
+ else Result := 0.0;
+ end;
+ end;
+end;
+
+function TQuery.GetDFlfByName(const Name: String): TDateTime;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := DField[ Idx ];
+end;
+
+function TQuery.GetFByNameAsStr(const Name: String): String;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := FieldAsStr[ Idx ];
+end;
+
+function TQuery.GetFieldAsHex(Idx: Integer): Pointer;
+begin
+ {if IsNull[ Idx ] then
+ Result := nil
+ else}
+ Result := FieldPtr( Idx );
+end;
+
+function TQuery.GetFieldAsStr(Idx: Integer): String;
+begin
+ if IsNull[ Idx ] then
+ Result := '(null)'
+ else
+ case ColType[ Idx ] of
+ ftReal:
+ //added optimize by azsd
+ begin
+ case fBindings[ Idx ].wType of
+ DBTYPE_NUMERIC,DBTYPE_VARNUMERIC:
+ if ShortInt(PDBNumeric(FieldPtr(Idx)).scale)<>0 then
+ Result := Double2Str( RField[ Idx ] )
+ else
+ Result := Int64_2Str( LField[ Idx ] );
+ else
+ Result := Double2Str( RField[ Idx ] );
+ end;
+ end;
+ ftString: Result := SField[ Idx ];
+ ftDate: Result := DateTime2StrShort( DField[ Idx ] );
+ ftLargeInt: Result := Int64_2Str( LField[ Idx ] );//add by azsd
+ //ftInteger:
+ else Result := Int2Str( IField[ Idx ] );
+ //else Result := '(?)';
+ end;
+end;
+
+function TQuery.GetFieldByNameAsHex(const Name: String): Pointer;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := FieldAsHex[ Idx ];
+end;
+
+function TQuery.GetFltField(Idx: Integer): Double;
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Result := 0.0
+ else
+ case fBindings[ Idx ].wType of
+ DBTYPE_R4: Result := PSingle( P )^;
+ DBTYPE_R8: Result := PDouble( P )^;
+ DBTYPE_CY: Result := PInteger( P )^ * 0.0001;
+ //TODO: DBTYPE_DECIMAL
+ DBTYPE_NUMERIC, DBTYPE_VARNUMERIC:
+ begin
+ Result := Int64_2Double(GetFixupNumeric(Idx));
+ if PDBNumeric(P).sign=0 then Result := 0 - Result;
+ if PDBNumeric(P).scale<>0 then Result := Result * IntPower( 10, 0 - Shortint(PDBNumeric(P).scale));
+ end;
+ else Result := 0.0;
+ end;
+end;
+
+function TQuery.GetFixupNumeric(Idx: Integer): Int64;
+var
+ P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ Result := MakeInt64( 0, 0 );
+ if P=nil then Exit;
+ case fBindings[ Idx ].wType of
+ DBTYPE_NUMERIC:
+ Result := PInt64( DWORD(P)+3 )^; //131 filled with 00
+ DBTYPE_VARNUMERIC:
+ begin
+ Result := PInt64( DWORD(P)+3 )^; //139 containing some shit bytes
+ //vn := P;
+ //if vn.precision> then
+ //fix-up done in Fetchdata
+ end;
+ else
+ Result := MakeInt64( PDWORD( DWORD(P)+3 )^, 0 );
+ end;
+end;
+
+function TQuery.GetI64Field(Idx: Integer): Int64;
+const His: array[ 0..1 ] of Integer = ( 0, -1 and not 255 );
+var P: Pointer;
+ B: Byte;
+begin
+ P := FieldPtr( Idx );
+ Result := MakeInt64( 0, 0 );
+ if P <> nil then
+ case fBindings[ Idx ].wType of
+ DBTYPE_I8, DBTYPE_UI8, DBTYPE_CY:
+ Result := PInt64( P )^;
+ DBTYPE_I1:
+ begin
+ B := PByte( P )^;
+ Result := Int2Int64( Integer( B ) or His[ B shr 7 ] );
+ end;
+ DBTYPE_UI1: Result := MakeInt64( PByte( P )^, 0 );
+ DBTYPE_I2: Result := Int2Int64( PShortInt( P )^ );
+ DBTYPE_UI2: Result := MakeInt64( PWord( P )^, 0 );
+ DBTYPE_I4: Result := Int2Int64( PInteger( P )^ );
+ DBTYPE_NUMERIC, DBTYPE_VARNUMERIC:
+ begin
+ if ShortInt(PDBNumeric(P).scale)<>0 then
+ Result := Double2Int64( RField[Idx] )
+ else
+ Result := GetFixupNumeric(Idx);
+ end;
+ //DBTYPE_UI4:
+ else Result := MakeInt64( PInteger( P )^, 0 );
+ end;
+end;
+
+function TQuery.GetI64FldByName(const Name: String): Int64;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := LField[ Idx ];
+end;
+
+function TQuery.GetIFieldByName(const Name: String): Integer;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := IField[ Idx ];
+end;
+
+function TQuery.GetIntField(Idx: Integer): Integer;
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Result := 0
+ else
+ case fBindings[ Idx ].wType of
+ DBTYPE_I1: begin
+ Result := PByte( P )^;
+ if LongBool( Result and $80) then
+ Result := Result or not $7F;
+ end;
+ DBTYPE_UI1: Result := PByte( P )^;
+ DBTYPE_I2, DBTYPE_UI2, DBTYPE_BOOL: Result := PShortInt( P )^;
+ DBTYPE_NUMERIC, DBTYPE_VARNUMERIC:
+ begin
+ if ShortInt(PDBNumeric(P).scale)<>0 then
+ Result := Round( RField[Idx] )
+ else
+ Result := GetFixupNumeric(Idx).Lo;
+ end;
+ //DBTYPE_I4, DBTYPE_UI4, DBTYPE_HCHAPTER:
+ else Result := PInteger( P )^;
+ end;
+end;
+
+function TQuery.GetIsNull(Idx: Integer): Boolean;
+var P: PDWORD;
+begin
+ Result := TRUE;
+ if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then
+ Exit;
+ P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) +
+ fBindings[ Idx ].obStatus );
+ Result := P^ = DBSTATUS_S_ISNULL;
+end;
+
+function TQuery.GetIsNullByName(const Name: String): Boolean;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := IsNull[ Idx ];
+end;
+
+function TQuery.GetRawType(Idx: Integer): DWORD;
+begin
+ Result := 0;
+ if fBindings = nil then Exit;
+ Result := fBindings[ Idx ].wType;
+end;
+
+function TQuery.GetRawTypeByName(const Name: String): DWORD;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := RawType[ Idx ];
+end;
+
+function TQuery.GetRFieldByName(const Name: String): Double;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := RField[ Idx ];
+end;
+
+function TQuery.GetRowCount: Integer;
+begin
+ {if fRowsAffected = DB_S_ASYNCHRONOUS then
+ begin
+ // only for asynchronous connections - do not see now
+ end;}
+ Result := fRowsAffected;
+end;
+
+function TQuery.GetRowsKnown: Integer;
+begin
+ Result := fRowsAffected;
+ if Result = 0 then
+ if fRowBuffers <> nil then
+ Result := fRowBuffers.Count;
+end;
+
+function TQuery.GetSFieldByName(const Name: String): String;
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ Result := SField[ Idx ];
+end;
+
+function TQuery.GetStrField(Idx: Integer): String;
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Result := ''
+ else
+ if fBindings[ Idx ].wType = DBTYPE_STR then
+ Result := PChar( P )
+ else
+ Result := PWideChar( P );
+end;
+
+procedure TQuery.Last;
+begin
+ while not EOF do
+ Next; //WOFetch( 0 );
+ if RowsKnown > 0 then
+ fCurIndex := RowsKnown;
+ Prev;
+ //FetchData;
+ fEOF := FALSE;
+end;
+
+procedure TQuery.MarkFieldChanged(Idx: Integer);
+begin
+ Changed( Idx );
+end;
+
+procedure TQuery.MarkFieldChangedByName(const Name: String);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ MarkFieldChanged( Idx );
+end;
+
+procedure TQuery.Next;
+begin
+ NextWOFetch( 0 );
+ FetchData;
+end;
+
+procedure TQuery.NextWOFetch( Skip: Integer );
+var Obtained: UINT;
+ PHandle: Pointer;
+ hr: HResult;
+begin
+ ReleaseHandle;
+ PHandle := @fRowHandle;
+ if (fCurIndex = fRowsAffected) and (Skip = -2) then
+ hr := fRowSet.GetNextRows( 0, -1, 1, Obtained, @PHandle )
+ else
+ hr := fRowSet.GetNextRows( 0, Skip, 1, Obtained, @PHandle );
+ if hr <> DB_S_ENDOFROWSET then
+ CheckOLE( hr );
+ Inc( fCurIndex, Skip + 1 );
+ if Obtained = 0 then
+ begin
+ fEOF := TRUE;
+ if fRowBuffers <> nil then
+ fRowsAffected := fRowBuffers.Count;
+ end
+ else
+ begin
+ if fRowBuffers = nil then
+ fRowBuffers := NewList;
+ if fCurIndex >= fRowBuffers.Count then
+ fRowBuffers.Add( nil );
+ end;
+end;
+
+procedure TQuery.Open;
+const
+ DB_NULLID: DBID = (uguid: (guid: (D1: 0; D2: 0; D3:0; D4: (0, 0, 0, 0, 0, 0, 0, 0)));
+ ekind: 1 {DBKIND_GUID_PROPID}; uname: (ulpropid:0));
+
+var ColInfo: IColumnsInfo;
+ AccessorIntf: IAccessor;
+ I: Integer;
+ OK: Boolean;
+
+ PropSets: array[0..0] of TDBPropset;
+ Props: array[ 0..0 ] of TDBProp;
+begin
+ ClearRowset;
+ if CheckOLE( fCommand.SetCommandText( @DBGUID_DBSQL, StringToOleStr( fText ) ) ) then
+ begin
+ if Mode = rmReadOnly then
+ begin
+ if not CheckOLE( fCommand.Execute( nil, IID_IROWSET, nil, @fRowsAffected, PIUnknown( @fRowSet ) ) ) then
+ Exit;
+ end
+ else
+ begin
+ // Add by ECM !!!
+ {$IFNDEF IBPROVIDER}
+ if fCommandProps = nil then
+ begin
+ if CheckOLE( fCommand.QueryInterface( IID_ICommandProperties, fCommandProps ) ) then
+ begin
+ PropSets[0].rgProperties := @ Props[ 0 ];
+ PropSets[0].cProperties := 1;
+ PropSets[0].guidPropertySet := DBPROPSET_ROWSET;
+
+ Props[0].dwPropertyID := $00000075; //DBPROP_UPDATABILITY
+ Props[0].dwOptions := 0; //DBPROPOPTIONS_REQUIRED;
+ Props[0].dwStatus := 0; //DBPROPSTATUS_OK;
+ Props[0].colid := DB_NULLID;
+ Props[0].vValue.vt := VT_I4;
+ Props[0].vValue.lVal := 1; //DBPROPVAL_UP_CHANGE;
+ end;
+ end;
+ CheckOLE( fCommandProps.SetProperties( 1, @ PropSets[ 0 ] ) );
+ {$ENDIF}
+ if not CheckOLE( fCommand.Execute( nil, IID_IROWSETCHANGE, nil, nil, PIUnknown( @ fRowSetChg ) ) ) then
+ Exit;
+ if not CheckOLE( fRowSetChg.QueryInterface( IID_IROWSET, fRowSet ) ) then
+ Exit;
+ if Mode = rmUpdateDelayed then
+ CheckOLE( fRowSetChg.QueryInterface( IID_IROWSETUPDATE, fRowSetUpd ) );
+ end;
+
+ if fRowsAffected = 0 then
+ Dec( fRowsAffected ); // RowCount = -1 means that RowCount is an unknown value
+ if fRowSetChg <> nil then
+ begin
+ OK := CheckOLE( fRowSetChg.QueryInterface( IID_IColumnsInfo, ColInfo ) );
+ end
+ else
+ begin
+ OK := CheckOLE( fRowSet.QueryInterface( IID_IColumnsInfo, ColInfo ) );
+ end;
+ if OK then
+ if CheckOLE( ColInfo.GetColumnInfo( fColCount, PDBColumnInfo( fColInfo ), fColNames ) ) then
+ begin
+ fBindings := AllocMem( Sizeof( TDBBinding ) * fColCount);
+ for I := 0 to fColCount - 1 do
+ begin
+ fBindings[ I ].iOrdinal := fColInfo[ I ].iOrdinal;
+ fBindings[ I ].obValue := fRowSize + 4;
+ // fBindings[ I ].obLength := 0;
+ fBindings[ I ].obStatus := fRowSize;
+ // fBindings[ I ].pTypeInfo := nil;
+ // fBindings[ I ].pObject := nil;
+ // fBindings[ I ].pBindExt := nil;
+ fBindings[ I ].dwPart := 1 + 4; //DBPART_VALUE + DBPART_STATUS;
+ // fBindings[ I ].dwMemOwner := 0; //DBMEMOWNER_CLIENTOWNED;
+ // fBindings[ I ].eParamIO := 0; //DBPARAMIO_NOTPARAM;
+ fBindings[ I ].cbMaxLen := fColInfo[ I ].ulColumnSize;
+ case fColInfo[ I ].wType of
+ DBTYPE_BSTR: Inc( fBindings[ I ].cbMaxLen, 1 );
+ DBTYPE_WSTR: fBindings[ I ].cbMaxLen := fBindings[ I ].cbMaxLen * 2 + 2;
+ end;
+ fBindings[ I ].cbMaxLen := (fBindings[ I ].cbMaxLen + 3) and not 3;
+ // fBindings[ I ].dwFlags := 0;
+ fBindings[ I ].wType := fColInfo[ I ].wType;
+ fBindings[ I ].bPrecision := fColInfo[ I ].bPrecision;
+ fBindings[ I ].bScale := fColInfo[ I ].bScale;
+ Inc( fRowSize, fBindings[ I ].cbMaxLen + 4 );
+ end;
+ fBindStatus := AllocMem( Sizeof( DBBINDSTATUS ) * fColCount );
+ if fRowSetChg <> nil then
+ begin
+ OK := CheckOLE( fRowSetChg.QueryInterface( IID_IAccessor, AccessorIntf ) );
+ end
+ else
+ begin
+ OK := CheckOLE( fRowSet.QueryInterface( IID_IAccessor, AccessorIntf ) );
+ end;
+ if OK then
+ CheckOLE(
+ AccessorIntf.CreateAccessor(
+ 2, //DBACCESSOR_ROWDATA, // Accessor will be used to retrieve row data
+ fColCount, // Number of columns being bound
+ fBindings, // Structure containing bind info
+ 0, // Not used for row accessors
+ fAccessor, // Returned accessor handle
+ PUIntArray( fBindStatus ) // Information about binding validity
+ )
+ );
+ fEOF := FALSE;
+ fCurIndex := -1;
+ First;
+ end;
+ end;
+end;
+
+procedure TQuery.Post;
+var R: HResult;
+ {P: PChar;
+ I: Integer;}
+begin
+ if not fChanged then Exit;
+ if fRowSetChg = nil then Exit;
+ R := fRowSetChg.SetData( fRowHandle, fAccessor, fRowBuffers.Items[ fCurIndex ] );
+ if R <> HResult( $00040EDA {DB_S_ERRORSOCCURED} ) then
+ CheckOLE( R )
+ { // я вижу только статус DBSTATUS_E_INTEGRITYVIOLATION касательно 0-й колонки,
+ // которую никто не просил добавлять во время выборки.
+ else
+ begin
+ asm
+ int 3
+ end;
+ for I := 0 to fColCount-1 do
+ begin
+ P := Pointer( DWORD( fRowBuffers.Items[ fCurIndex ] ) +
+ fBindings[ I ].obStatus );
+ ShowMessage( fColInfo[I].pwszName + '.Status=' + Int2Hex( PDWORD( P )^, 8 ) );
+ end;
+ end};
+ fChanged := FALSE;
+end;
+
+procedure TQuery.Prev;
+begin
+ if CurIndex > 0 then
+ begin
+ NextWOFetch( -2 ); //***
+ //Dec( fCurIndex );
+ fEOF := FALSE;
+ FetchData; //***
+ end;
+end;
+
+procedure TQuery.ReleaseHandle;
+begin
+ if fRowHandle <> 0 then
+ CheckOLE( fRowSet.ReleaseRows( 1, @fRowHandle, nil, nil, nil ) );
+ fRowHandle := 0;
+end;
+
+procedure TQuery.SetCurIndex(const Value: Integer);
+var OldCurIndex: Integer;
+begin
+ OldCurIndex := fCurIndex;
+ if fCurIndex = Value then
+ begin
+ if fRowHandle = 0 then
+ FetchData;
+ if fRowHandle <> 0 then
+ Exit;
+ end;
+ if Value = 0 then
+ First
+ else
+ if Value >= fRowsAffected - 1 then
+ Last;
+
+ fEOF := FALSE;
+ while (fCurIndex < Value) and not EOF do
+ Next;
+ while (fCurIndex > Value) and not EOF do
+ Prev;
+
+ if fCurIndex = Value then
+ FetchData
+ else
+ fCurIndex := OldCurIndex;
+end;
+
+procedure TQuery.SetDField(Idx: Integer; const Value: TDateTime);
+var P: Pointer;
+ ST: TSystemTime;
+ pD: PDBDate;
+ pT: PDBTime;
+ TS: PDBTimeStamp;
+ pFT: PFileTime;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then Exit;
+ case fBindings[ Idx ].wType of
+ DBTYPE_DATE: PDouble( P )^ := Value - VCLDate0;
+ DBTYPE_DBDATE:
+ begin
+ pD := P;
+ DateTime2SystemTime( Value, ST );
+ pD.year := ST.wYear;
+ pD.month := ST.wMonth;
+ pD.day := ST.wDay;
+ end;
+ DBTYPE_DBTIME:
+ begin
+ pT := P;
+ DateTime2SystemTime( Value, ST );
+ pT.hour := ST.wHour;
+ pT.minute := ST.wMinute;
+ pT.second := ST.wSecond;
+ end;
+ DBTYPE_DBTIMESTAMP:
+ begin
+ TS := P;
+ DateTime2SystemTime( Value, ST );
+ TS.year := ST.wYear;
+ TS.month := ST.wMonth;
+ TS.day := ST.wDay;
+ TS.hour := ST.wHour;
+ TS.minute := ST.wMinute;
+ TS.second := ST.wSecond;
+ TS.fraction := ST.wMilliseconds * 1000;
+ end;
+ DBTYPE_FILETIME:
+ begin
+ pFT := P;
+ DateTime2SystemTime( Value, ST );
+ SystemTimeToFileTime( ST, pFT^ );
+ end;
+ else Exit;
+ end;
+ Changed( Idx );
+end;
+
+procedure TQuery.SetDFldByName(const Name: String; const Value: TDateTime);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ DField[ Idx ] := Value;
+end;
+
+procedure TQuery.SetFByNameFromStr(const Name, Value: String);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ FieldAsStr[ Idx ] := Value;
+end;
+
+procedure TQuery.SetFieldFromStr(Idx: Integer; const Value: String);
+begin
+ if StrEq( Value, '(null)' ) and (ColType[ Idx ] <> ftString) then
+ IsNull[ Idx ] := TRUE
+ else
+ case ColType[ Idx ] of
+ ftInteger: IField[ Idx ] := Str2Int( Value );
+ ftReal: RField[ Idx ] := Str2Double( Value );
+ ftString: SField[ Idx ] := Value;
+ ftDate: DField[ Idx ] := Str2DateTimeShort( Value );
+ end;
+end;
+
+procedure TQuery.SetFltField(Idx: Integer; const Value: Double);
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Exit;
+ case fBindings[ Idx ].wType of
+ DBTYPE_R4: PExtended( P )^ := Value;
+ DBTYPE_R8: PDouble( P )^ := Value;
+ DBTYPE_CY: PInteger( P )^ := Round( Value * 10000 );
+ //TODO: DBTYPE_NUMERIC, DBTYPE_VARNUMERIC, DBTYPE_DECIMAL
+ else Exit;
+ end;
+ Changed( Idx );
+end;
+
+procedure TQuery.SetI64Field(Idx: Integer; const Value: Int64);
+begin
+
+end;
+
+procedure TQuery.SetI64FldByName(const Name: String; const Value: Int64);
+begin
+
+end;
+
+procedure TQuery.SetIFieldByName(const Name: String; Value: Integer);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ IField[ Idx ] := Value;
+end;
+
+procedure TQuery.SetIntField(Idx: Integer; const Value: Integer);
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Exit;
+ case fBindings[ Idx ].wType of
+ DBTYPE_I1, DBTYPE_UI1: PByte( P )^ := Byte( Value );
+ DBTYPE_I2, DBTYPE_UI2: PShortInt( P )^ := Value;
+ DBTYPE_BOOL: if Value <> 0 then PShortInt( P )^ := -1
+ else PShortInt( P )^ := 0;
+ else PInteger( P )^ := Value;
+ end;
+ Changed( Idx );
+end;
+
+procedure TQuery.SetIsNull(Idx: Integer; const Value: Boolean);
+var P: PDWORD;
+begin
+ if not Value then Exit;
+ if (fRowSet = nil) or (fCurIndex < 0) or (DWORD(Idx) >= ColCount) then
+ Exit;
+ P := Changed( Idx );
+ P^ := DBSTATUS_S_ISNULL;
+end;
+
+procedure TQuery.SetIsNullByName(const Name: String; const Value: Boolean);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ IsNull[ Idx ] := Value;
+end;
+
+procedure TQuery.SetRFieldByName(const Name: String; const Value: Double);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ RField[ Idx ] := Value;
+end;
+
+procedure TQuery.SetSFieldByName(const Name: String; const Value: String);
+var Idx: Integer;
+begin
+ Idx := ColByName[ Name ];
+ Assert( Idx >=0, 'TQuery: incorrect column name (' + Name + ').' );
+ SField[ Idx ] := Value;
+end;
+
+procedure TQuery.SetStrField(Idx: Integer; const Value: String);
+var P: Pointer;
+begin
+ P := FieldPtr( Idx );
+ if P = nil then
+ Exit;
+ if fBindings[ Idx ].wType = DBTYPE_STR then
+ StrLCopy( PChar( P ), @ Value[ 1 ], fBindings[ Idx ].cbMaxLen )
+ else
+ StringToWideChar( Value, PWideChar( P ), fBindings[ Idx ].cbMaxLen );
+ Changed( Idx );
+end;
+
+procedure TQuery.SetText(const Value: String);
+begin
+ // clear here current rowset if any:
+ ClearRowset;
+ {// set txt to fCommand -- do this at the last moment just before execute
+ CheckOLE( fCommand.SetCommandText( DBGUID_DBSQL, StringToOleStr( Value ) ) );}
+ FText := Value;
+end;
+
+procedure TQuery.Update;
+var Params, Results: array of DWORD;
+ I: Integer;
+begin
+ if Mode <> rmUpdateDelayed then Exit;
+ if (fDelList <> nil) and (fDelList.Count > 0) then
+ begin
+ SetLength( Params, fDelList.Count );
+ SetLength( Results, fDelList.Count );
+ for I := 0 to fDelList.Count-1 do
+ Params[ I ] := DWORD( fDelList.Items[ I ] );
+ CheckOLE( fRowSetUpd.DeleteRows( 0, fDelList.Count, @ Params[ 0 ], @ Results[ 0 ] ) );
+ Free_And_Nil( fDelList );
+ end;
+ if fRowSetUpd = nil then Exit;
+ CheckOLE( fRowSetUpd.Update( 0, 0, nil, nil, nil, nil ) );
+end;
+
+end.
|