Skip to content

Instantly share code, notes, and snippets.

Embed
What would you like to do?
unit Data.Win.OleDbUtils;
interface
uses
System.Classes,
System.SysUtils,
System.Win.ComObj,
Winapi.Windows,
Winapi.ActiveX,
Winapi.ADOInt,
Winapi.OleDb,
Data.DB,
Data.Win.ADOConst,
Data.Win.ADODB;
const
DBPROPSET_SQLSERVERDATASOURCE: TGUID = '{28EFAEE4-2D2C-11D1-9807-00C04FC2AD98}';
SSPROP_ENABLEFASTLOAD = 2;
SIID_IRowsetFastLoad = '{5CF4CA13-EF21-11D0-97E7-00C04FC2AD98}';
SIID_IErrorRecords = '{0C733A67-2A1C-11CE-ADE5-00AA0044773D}';
IID_IRowsetFastLoad: TGUID = SIID_IRowsetFastLoad;
IID_IErrorRecords: TGUID = SIID_IErrorRecords;
type
DBLENGTH = ULONGLONG;
PColumnData = ^TColumnData;
TColumnData = record
Length: DBLENGTH;
Status: DBSTATUS;
Data: array[0..0] of Byte;
end;
IRowsetFastLoad = interface
[SIID_IRowsetFastLoad]
function InsertRow(hAccessor: HACCESSOR; pData: Pointer): HRESULT; stdcall;
function Commit(fDone: BOOL): HRESULT; stdcall;
end;
IErrorRecords = interface
[SIID_IErrorRecords]
function AddErrorRecord(pErrorInfo: PErrorInfo; dwLookupID: UINT; pDispParams: pointer; punkCustomError: IUnknown;
dwDynamicErrorID: UINT): HResult; stdcall;
function GetBasicErrorInfo(ulRecordNum: UINT; pErrorInfo: PErrorInfo): HResult; stdcall;
function GetCustomErrorObject(ulRecordNum: UINT; const riid: TGUID; var ppObject: IUnknown): HResult; stdcall;
function GetErrorInfo(ulRecordNum: UINT; lcid: UINT; var ppErrorInfo: IErrorInfo): HResult; stdcall;
function GetErrorParameters(ulRecordNum: UINT; pDispParams: pointer): HResult; stdcall;
function GetRecordCount(var pcRecords: UINT): HResult; stdcall;
end;
TOleDbError = record
Guid: TGUID;
BasicInfo: TErrorInfo;
Source: WideString;
Description: WideString;
HelpFile: WideString;
HelpContext: Integer;
SqlNativeError: Integer;
SqlState: WideString;
end;
TOleDbErrorDynArray = array of TOleDbError;
EOleDbError = class(EOleSysError)
Errors: TOleDbErrorDynArray;
end;
procedure BulkCopy(Dataset: TDataSet; Connection: TADOConnection; const DstTableName: string);
function FieldTypeToOleDbType(const FieldType: TFieldType): DBTYPEENUM;
procedure OleDbCheck(Result: HResult; const Instance: IUnknown; const IID: TGUID; StatusCodes: PUintArray = nil;
StatusCount: Integer = 0);
function OpenFastLoad(const DBCreateSession: IDBCreateSession; const TableName: WideString): IRowsetFastLoad; overload;
function OpenFastLoad(Connection: TADOConnection; const TableName: WideString): IRowsetFastLoad; overload;
procedure InitializeProperty(var Prop: TDBProp; PropID: DBPROPID; const Value: OleVariant);
procedure SetProperties(const DBProperties: IDBProperties; const PropertySetID: TGUID;
const PropertyIDs: array of Cardinal; const Values: OleVariant); overload;
procedure SetProperties(Connection: TADOConnection; const PropertySetID: TGUID; const PropertyIDs: array of Cardinal;
const Values: OleVariant); overload;
procedure SetProperty(const DBProperties: IDBProperties; const PropertySetID: TGUID; PropertyID: Cardinal;
const Value: OleVariant); overload;
procedure SetProperty(Connection: TADOConnection; const PropertySetID: TGUID; PropertyID: Cardinal;
const Value: OleVariant); overload;
implementation
uses
System.Variants;
procedure Align(var Value: Integer; Alignment: Byte = 8); forward;
procedure GetFieldValue(Field: TField; const Binding: TDBBinding; Buffer: Pointer; BlobList: TList); forward;
procedure InitializeBinding(Field: TField; var Binding: TDBBinding; var Offset: Integer); forward;
procedure Align(var Value: Integer; Alignment: Byte = 8);
var
M: Byte;
begin
M := Value mod Alignment;
if M <> 0 then
Inc(Value, Alignment - M);
end;
procedure BulkCopy(Dataset: TDataSet; Connection: TADOConnection; const DstTableName: string);
var
BlobList: TList;
Bindings: PDBBindingArray;
StatusCodes: PUIntArray;
Buffer: Pointer;
I, BufferSize: Integer;
FastLoad: IRowsetFastLoad;
Accessor: IAccessor;
AccessorHandle: THandle;
begin
BufferSize := 0;
BlobList := nil;
Bindings := AllocMem(Dataset.FieldCount * SizeOf(TDBBinding));
try
for I := 0 to Dataset.FieldCount - 1 do
begin
if not Assigned(BlobList) and Dataset.Fields[I].IsBlob then
BlobList := TList.Create;
InitializeBinding(Dataset.Fields[I], Bindings^[I], BufferSize);
end;
Buffer := AllocMem(BufferSize);
try
StatusCodes := AllocMem(Dataset.FieldCount * SizeOf(DBBINDSTATUS));
try
Connection.Connected := True;
FastLoad := OpenFastLoad(Connection, DstTableName);
OleDbCheck(FastLoad.QueryInterface(IID_IAccessor, Accessor), FastLoad, IID_IRowsetFastLoad, StatusCodes,
Dataset.FieldCount);
OleDbCheck(Accessor.CreateAccessor(DBACCESSOR_ROWDATA, Dataset.FieldCount, Bindings, BufferSize,
AccessorHandle, StatusCodes), Accessor, IID_IAccessor, StatusCodes, Dataset.FieldCount);
try
while not Dataset.Eof do
begin
try
for I := 0 to Dataset.FieldCount - 1 do
GetFieldValue(Dataset.Fields[I], Bindings^[I], Buffer, BlobList);
OleDbCheck(FastLoad.InsertRow(AccessorHandle, Buffer), FastLoad, IID_IRowsetFastLoad, StatusCodes,
Dataset.FieldCount);
finally
if Assigned(BlobList) then
begin
for I := 0 to BlobList.Count - 1 do
TStream(BlobList[I]).Free;
BlobList.Clear;
end;
end;
Dataset.Next;
end;
OleDbCheck(FastLoad.Commit(True), FastLoad, IID_IRowsetFastLoad, StatusCodes, Dataset.FieldCount);
finally
OleDbCheck(Accessor.ReleaseAccessor(AccessorHandle, nil), Accessor, IID_IAccessor, nil, 0);
end;
finally
FreeMem(StatusCodes);
end;
finally
FreeMem(Buffer);
end;
finally
FreeMem(Bindings);
BlobList.Free;
end;
end;
function FieldTypeToOleDbType(const FieldType: TFieldType): DBTYPEENUM;
begin
case FieldType of
ftUnknown: Result := DBTYPE_EMPTY; // ?
ftString, ftMemo, ftFixedChar: Result := DBTYPE_STR; // varchar
ftWideString, ftWideMemo, ftFixedWideChar: Result := DBTYPE_WSTR; // nvarchar
ftByte, ftShortint: Result := DBTYPE_I1; // tinyint
ftSmallint, ftWord: Result := DBTYPE_I2; // smallint
ftInteger, ftAutoInc, ftLongWord: Result := DBTYPE_I4; // int, identity
ftBoolean: Result := DBTYPE_BOOL; // bit
ftFloat: Result := DBTYPE_R8; // float
ftSingle: Result := DBTYPE_R4; // real
ftBCD, ftCurrency: Result := DBTYPE_CY; // money
ftDate: Result := DBTYPE_DBDATE; // date
ftTime: Result := DBTYPE_DBTIME; // time
ftDateTime, ftTimestamp: Result := DBTYPE_DBTIMESTAMP; // datetime
ftBytes, ftVarBytes, ftBlob, ftGraphic..ftTypedBinary: Result := DBTYPE_BYTES; // binary, varbinary, image
ftLargeint: Result := DBTYPE_I8; // bigint
ftVariant: Result := DBTYPE_VARIANT; // sql_variant
ftInterface: Result := DBTYPE_IUNKNOWN; // ?
ftIDispatch: Result := DBTYPE_IDISPATCH; // ?
ftGuid: Result := DBTYPE_GUID; // uniqueidentifier
else
DatabaseErrorFmt(SNoMatchingADOType, [FieldTypeNames[FieldType]]);
Result := adEmpty;
end;
end;
procedure GetFieldValue(Field: TField; const Binding: TDBBinding; Buffer: Pointer; BlobList: TList);
var
Column: PColumnData;
BlobStream, Stream: TStream;
MSec: Word;
begin
Column := Pointer(NativeUInt(Buffer) + Binding.obLength);
if Field.IsNull then
begin
Column^.Status := DBSTATUS_S_ISNULL;
Column^.Length := 0;
end
else if Field.IsBlob then
begin
BlobStream := Field.DataSet.CreateBlobStream(Field, bmRead);
try
if BlobStream is TMemoryStream then
begin
Stream := BlobStream;
BlobStream := nil;
BlobList.Add(Stream);
end
else
begin
Stream := TMemoryStream.Create;
try
Stream.CopyFrom(BlobStream, 0);
BlobList.Add(Stream);
except
Stream.Free;
raise;
end;
end;
Column^.Status := DBSTATUS_S_OK;
Column^.Length := Stream.Size;
PPointer(@Column^.Data[0])^ := TMemoryStream(Stream).Memory;
finally
BlobStream.Free;
end;
end
else
begin
case Field.DataType of
ftBCD, ftCurrency:
PCurrency(@Column.Data[0])^ := Field.AsCurrency;
ftDate:
with PDBDate(@Column^.Data[0])^ do
DecodeDate(Field.AsDateTime, Word(year), month, day);
ftTime:
with PDBTime(@Column^.Data[0])^ do
DecodeTime(Field.AsDateTime, hour, minute, second, MSec);
ftDateTime, ftTimeStamp:
with PDBTimeStamp(@Column^.Data[0])^ do
begin
DecodeDate(Field.AsDateTime, Word(year), month, day);
DecodeTime(Field.AsDateTime, hour, minute, second, MSec);
fraction := MSec * 1000000;
end;
else
Field.GetData(@Column^.Data[0], False);
end;
Column^.Status := DBSTATUS_S_OK;
case Field.DataType of
ftString, ftMemo:
Column^.Length := StrLen(PAnsiChar(@Column^.Data[0]));
ftWideString, ftWideMemo:
Column^.Length := StrLen(PWideChar(@Column^.Data[0])) * SizeOf(WideChar);
else
Column^.Length := Field.DataSize;
end;
end;
end;
procedure InitializeBinding(Field: TField; var Binding: TDBBinding; var Offset: Integer);
begin
Binding.iOrdinal := Field.FieldNo;
Binding.wType := FieldTypeToOleDbType(Field.DataType);
if Field.IsBlob then
Binding.wType := Binding.wType or DBTYPE_BYREF;
Binding.eParamIO := DBPARAMIO_NOTPARAM;
Binding.dwMemOwner := DBMEMOWNER_CLIENTOWNED;
Binding.obLength := Offset;
Binding.obStatus := Binding.obLength + SizeOf(DBLENGTH);
Binding.obValue := Binding.obStatus + SizeOf(DBSTATUS);
Binding.dwPart := DBPART_LENGTH or DBPART_STATUS or DBPART_VALUE;
case Field.DataType of
ftDate:
Binding.cbMaxLen := SizeOf(TDBDate);
ftTime:
Binding.cbMaxLen := SizeOf(TDBTime);
ftDateTime, ftTimeStamp:
Binding.cbMaxLen := SizeOf(TDBTimeStamp);
else
Binding.cbMaxLen := Field.DataSize;
end;
Inc(Offset, SizeOf(TColumnData) + Binding.cbMaxLen - 1);
Align(Offset);
end;
procedure InitializeProperty(var Prop: TDBProp; PropID: DBPROPID; const Value: OleVariant);
begin
Prop.dwPropertyID := PropID;
Prop.dwOptions := DBPROPOPTIONS_REQUIRED;
Prop.colid := DB_NULLID;
Prop.vValue := Value;
end;
procedure OleDbCheck(Result: HResult; const Instance: IUnknown; const IID: TGUID; StatusCodes: PUintArray;
StatusCount: Integer);
var
SupportErrorInfo: ISupportErrorInfo;
ErrorInfo: IErrorInfo;
I: Integer;
ErrorRecords: IErrorRecords;
ErrorCount: Cardinal;
SqlErrorInfoIntf: IInterface;
SqlErrorInfo: ISQLErrorInfo;
Errors: TOleDbErrorDynArray;
E: EOleDbError;
SErrorMessage: string;
begin
if Succeeded(Result) then
Exit;
if not Succeeded(Instance.QueryInterface(ISupportErrorInfo, SupportErrorInfo)) or
not Succeeded(SupportErrorInfo.InterfaceSupportsErrorInfo(IID)) or
not Succeeded(GetErrorInfo(0, ErrorInfo)) then
OleCheck(Result);
if Succeeded(ErrorInfo.QueryInterface(IID_IErrorRecords, ErrorRecords)) and
Succeeded(ErrorRecords.GetRecordCount(ErrorCount)) then
SetLength(Errors, ErrorCount + 1)
else
SetLength(Errors, 1);
Errors[0].BasicInfo.hrError := Result;
Errors[0].BasicInfo.iid := IID;
ErrorInfo.GetGUID(Errors[0].Guid);
ErrorInfo.GetSource(Errors[0].Source);
ErrorInfo.GetDescription(Errors[0].Description);
ErrorInfo.GetHelpFile(Errors[0].HelpFile);
ErrorInfo.GetHelpContext(Errors[0].HelpContext);
for I := 0 to ErrorCount - 1 do
begin
ErrorRecords.GetBasicErrorInfo(I, @Errors[I + 1].BasicInfo);
if Succeeded(ErrorRecords.GetErrorInfo(I, LOCALE_SYSTEM_DEFAULT, ErrorInfo)) then
begin
ErrorInfo.GetGUID(Errors[I + 1].Guid);
ErrorInfo.GetSource(Errors[I + 1].Source);
ErrorInfo.GetDescription(Errors[I + 1].Description);
ErrorInfo.GetHelpFile(Errors[I + 1].HelpFile);
ErrorInfo.GetHelpContext(Errors[I + 1].HelpContext);
end;
if Succeeded(ErrorRecords.GetCustomErrorObject(I, IID_ISQLErrorInfo, SqlErrorInfoIntf)) and
Supports(SqlErrorInfoIntf, IID_ISQLErrorInfo, SqlErrorInfo) then
SqlErrorInfo.GetSQLInfo(Errors[I + 1].SqlState, Errors[I + 1].SqlNativeError);
end;
SErrorMessage := '';
for I := 0 to StatusCount - 1 do
begin
if SErrorMessage <> '' then
SErrorMessage := SErrorMessage + ', ';
SErrorMessage := SErrorMessage + IntToStr(StatusCodes^[I]);
end;
if SErrorMessage = '' then
SErrorMessage := Errors[0].Description
else
SErrorMessage := Format('%s (status codes: %s)', [Errors[0].Description, SErrorMessage]);
E := EOleDbError.Create(SErrorMessage, Errors[0].BasicInfo.hrError, Errors[0].HelpContext);
E.Errors := Errors;
raise E;
end;
function OpenFastLoad(const DBCreateSession: IDBCreateSession; const TableName: WideString): IRowsetFastLoad; overload;
var
OpenRowSet: IOpenRowset;
TableID: TDBID;
begin
OleDbCheck(DBCreateSession.CreateSession(nil, IID_IOpenRowset, IUnknown(OpenRowSet)), DBCreateSession,
IID_IDBCreateSession, nil, 0);
TableID.eKind := DBKIND_NAME;
TableID.uName.pwszName := PWideChar(TableName);
OleDbCheck(OpenRowSet.OpenRowset(nil, @TableID, nil, IID_IRowsetFastLoad, 0, nil, @Result), OpenRowSet,
IID_IOpenRowset, nil, 0);
end;
function OpenFastLoad(Connection: TADOConnection; const TableName: WideString): IRowsetFastLoad; overload;
var
ConnectionConstruction: ADOConnectionConstruction;
begin
SetProperty(Connection, DBPROPSET_SQLSERVERDATASOURCE, SSPROP_ENABLEFASTLOAD, True);
ConnectionConstruction := Connection.ConnectionObject as ADOConnectionConstruction;
Result := OpenFastLoad(ConnectionConstruction.Get_DSO as IDBCreateSession, TableName);
end;
procedure SetProperties(const DBProperties: IDBProperties; const PropertySetID: TGUID;
const PropertyIDs: array of Cardinal; const Values: OleVariant); overload;
var
Count, I: Integer;
DBPropSets: array[0..0] of TDBPropSet;
DBProps: PDBPropArray;
begin
Count := Length(PropertyIDs);
if Count = 0 then
Exit;
DBProps := AllocMem(Count * SizeOf(TDBProp));
try
DBPropSets[0].rgProperties := DbProps;
DBPropSets[0].cProperties := Count;
DBPropSets[0].guidPropertySet := PropertySetID;
for I := 0 to Count - 1 do
InitializeProperty(DBProps^[I], PropertyIDs[I], VarArrayGet(Values, [I]));
OleCheck(DBProperties.SetProperties(1, @DBPropSets));
finally
FreeMem(DBProps);
end;
end;
procedure SetProperties(Connection: TADOConnection; const PropertySetID: TGUID; const PropertyIDs: array of Cardinal;
const Values: OleVariant); overload;
var
ConnectionConstruction: ADOConnectionConstruction;
begin
ConnectionConstruction := Connection.ConnectionObject as ADOConnectionConstruction;
SetProperties(ConnectionConstruction.Get_DSO as IDBProperties, PropertySetID, PropertyIDs, Values);
end;
procedure SetProperty(const DBProperties: IDBProperties; const PropertySetID: TGUID; PropertyID: Cardinal;
const Value: OleVariant); overload;
var
DBPropSets: array[0..0] of TDBPropSet;
DBProps: array[0..0] of TDBProp;
begin
DBPropSets[0].rgProperties := @DBProps;
DBPropSets[0].cProperties := 1;
DBPropSets[0].guidPropertySet := PropertySetID;
InitializeProperty(DBProps[0], PropertyID, Value);
OleCheck(DBProperties.SetProperties(1, @DBPropSets));
end;
procedure SetProperty(Connection: TADOConnection; const PropertySetID: TGUID; PropertyID: Cardinal;
const Value: OleVariant); overload;
var
ConnectionConstruction: ADOConnectionConstruction;
begin
ConnectionConstruction := Connection.ConnectionObject as ADOConnectionConstruction;
SetProperty(ConnectionConstruction.Get_DSO as IDBProperties, PropertySetID, PropertyID, Value);
end;
end.
@trojanhost

This comment has been minimized.

Copy link

commented Feb 8, 2018

this bulkcopy lib can not run triggers.. so.. i updated this code:

function OpenFastLoad(const DBCreateSession: IDBCreateSession; const TableName: WideString): IRowsetFastLoad; overload;
var
OpenRowSet: IOpenRowset;
TableID: TDBID;
DBPropSets: array[0..0] of TDBPropSet;
DBProps: array[0..0] of TDBProp;
begin
OleDbCheck(DBCreateSession.CreateSession(nil, IID_IOpenRowset, IUnknown(OpenRowSet)), DBCreateSession,
IID_IDBCreateSession, nil, 0);
TableID.eKind := DBKIND_NAME;
TableID.uName.pwszName := PWideChar(TableName);

DBProps[0].dwOptions := DBPROPOPTIONS_OPTIONAL; //DBPROPOPTIONS_REQUIRED
DBProps[0].colid := DB_NULLID;
DBProps[0].dwStatus := DBPROPSTATUS_OK; // =0
DBProps[0].dwPropertyID := SSPROP_FASTLOADOPTIONS; // =9
DBProps[0].vValue := 'FIRE_TRIGGERS'; // for run Table Triggers!
DBPropSets[0].guidPropertySet := DBPROPSET_SQLSERVERROWSET; // '{5CF4CA11-EF21-11D0-97E7-00C04FC2AD98}'
DBPropSets[0].cProperties := 1;
DBPropSets[0].rgProperties := @DBProps;

OleDbCheck(OpenRowSet.OpenRowset(nil, @TableID, nil, IID_IRowsetFastLoad, 1, @DBPropSets, @Result), OpenRowSet,
IID_IOpenRowset, nil, 0);
end;

working good - ok! trigger good run! (SQLNCLI11 or SQLOLEDB)

Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
You can’t perform that action at this time.