pascal/kolmck
pascal/kolmck
1
0
Fork 0
Code Issues Releases Activity
kolmck/Addons/KOLEdb.pas

2210 lines
74 KiB
ObjectPascal
Raw Blame History

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.
Reference in New Issue View Git Blame Copy Permalink