zeoslib  UNKNOWN
 All Files
ZDbcAdoUtils.pas
Go to the documentation of this file.
1 {*********************************************************}
2 { }
3 { Zeos Database Objects }
4 { ADO Specific Utilities }
5 { }
6 { Originally written by Janos Fegyverneki }
7 { }
8 {*********************************************************}
9 
10 {@********************************************************}
11 { Copyright (c) 1999-2012 Zeos Development Group }
12 { }
13 { License Agreement: }
14 { }
15 { This library is distributed in the hope that it will be }
16 { useful, but WITHOUT ANY WARRANTY; without even the }
17 { implied warranty of MERCHANTABILITY or FITNESS FOR }
18 { A PARTICULAR PURPOSE. See the GNU Lesser General }
19 { Public License for more details. }
20 { }
21 { The source code of the ZEOS Libraries and packages are }
22 { distributed under the Library GNU General Public }
23 { License (see the file COPYING / COPYING.ZEOS) }
24 { with the following modification: }
25 { As a special exception, the copyright holders of this }
26 { library give you permission to link this library with }
27 { independent modules to produce an executable, }
28 { regardless of the license terms of these independent }
29 { modules, and to copy and distribute the resulting }
30 { executable under terms of your choice, provided that }
31 { you also meet, for each linked independent module, }
32 { the terms and conditions of the license of that module. }
33 { An independent module is a module which is not derived }
34 { from or based on this library. If you modify this }
35 { library, you may extend this exception to your version }
36 { of the library, but you are not obligated to do so. }
37 { If you do not wish to do so, delete this exception }
38 { statement from your version. }
39 { }
40 { }
41 { The project web site is located on: }
42 { http://zeos.firmos.at (FORUM) }
43 { http://sourceforge.net/p/zeoslib/tickets/ (BUGTRACKER)}
44 { svn://svn.code.sf.net/p/zeoslib/code-0/trunk (SVN) }
45 { }
46 { http://www.sourceforge.net/projects/zeoslib. }
47 { }
48 { }
49 { Zeos Development Group. }
50 {********************************************************@}
51 
52 unit ZDbcAdoUtils;
53 
54 interface
55 
56 {$I ZDbc.inc}
57 
58 uses Windows, Classes, {$IFDEF MSEgui}mclasses,{$ENDIF} SysUtils, ActiveX,
59  ZDbcIntfs, ZCompatibility, ZPlainAdo, ZDbcAdo, ZVariant;
60 
61 type
62  PDirectionTypes = ^TDirectionTypes;
63  TDirectionTypes = array of TOleEnum;
64 
65 {**
66  Converts an ADO native types into string related.
67  @param FieldType dblibc native field type.
68  @return a string data type name.
69 }
70 function ConvertAdoToTypeName(FieldType: SmallInt): string;
71 
72 {**
73  Converts a Ado native types into ZDBC SQL types.
74  @param FieldType dblibc native field type.
75  @return a SQL undepended type.
76 }
77 function ConvertAdoToSqlType(const FieldType: SmallInt;
78  const CtrlsCPType: TZControlsCodePage; UseCtrsCPType: Boolean = True): TZSQLType;
79 
80 {**
81  Converts a Zeos type into ADO types.
82  @param FieldType zeos field type.
83  @return a ADO datatype.
84 }
85 function ConvertSqlTypeToAdo(FieldType: TZSQLType): Integer;
86 
87 {**
88  Converts a Variant type into ADO types.
89  @param VT Variant datatype.
90  @return a ADO datatype.
91 }
92 {$IFDEF FPC}
93 function ConvertVariantToAdo(VT: Integer): Integer;
94 {$ELSE}
95 function ConvertVariantToAdo(VT: TVarType): Integer;
96 {$ENDIF}
97 
98 {**
99  Converts a TZResultSetType type into ADO cursor type.
100  @param ResultSetType.
101  @return a ADO cursor type.
102 }
103 function ConvertResultSetTypeToAdo(ResultSetType: TZResultSetType): Integer;
104 
105 {**
106  Converts a TZResultSetConcurrency type into ADO lock type.
107  @param ResultSetConcurrency.
108  @return a ADO lock type.
109 }
110 function ConvertResultSetConcurrencyToAdo(ResultSetConcurrency: TZResultSetConcurrency): Integer;
111 
112 {**
113  Converts a OLEDB schema guid into ADO schema ID usable with OpenSchema.
114  @param OleDBSchema schema guid.
115  @return a ADO schema id.
116 }
117 function ConvertOleDBToAdoSchema(OleDBSchema: TGUID): Integer;
118 
119 {**
120  Brings up the ADO connection string builder dialog.
121 }
122 function PromptDataSource(Handle: THandle; InitialString: WideString): WideString;
123 
124 function GetCurrentResultSet(AdoRecordSet: ZPlainAdo.RecordSet;
125  Connection: IZAdoConnection; Statement: IZStatement; Const SQL: String;
126  ConSettings: PZConSettings;
127  const ResultSetConcurrency: TZResultSetConcurrency): IZResultSet;
128 
129 function IsSelect(const SQL: string): Boolean;
130 
131 {**
132  Sets a variant value into specified parameter.
133  @param AdoCommand the ole command
134  @param Connection the Connection interface
135  @param ParameterIndex a index of the parameter.
136  @param SqlType a parameter SQL type.
137  @paran Value a new parameter value.
138 }
139 procedure ADOSetInParam(AdoCommand: ZPlainAdo.Command; Connection: IZConnection;
140  ParamCount: Integer; const ParameterIndex: Integer;
141  const SQLType: TZSQLType; const Value: TZVariant;
142  const ParamDirection: ParameterDirectionEnum);
143 
144 procedure RefreshParameters(AdoCommand: ZPlainAdo.Command; DirectionTypes: PDirectionTypes = nil);
145 
146 var
147 {**
148  Required to free memory allocated by oledb
149 }
150  ZAdoMalloc: IMalloc;
151 
152 implementation
153 
154 uses
155  ComObj, {$IFDEF FPC}ZOleDB{$ELSE}OleDB{$ENDIF}, Variants, Types, Math,
156  ZSysUtils, ZDbcAdoResultSet, ZDbcCachedResultSet, ZDbcResultSet, ZDbcUtils,
157  ZMessages, ZEncoding;
158 
159 {**
160  Converts an ADO native types into string related.
161  @param FieldType dblibc native field type.
162  @return a string data type name.
163 }
164 function ConvertAdoToTypeName(FieldType: SmallInt): string;
165 begin
166  case FieldType of
167  adChar : Result := 'Char';
168  adVarChar : Result := 'VarChar';
169  adBSTR : Result := 'BSTR';
170  adWChar : Result := 'WChar';
171  adVarWChar : Result := 'VarWChar';
172  adBoolean : Result := 'Boolean';
173  adTinyInt : Result := 'TinyInt';
174  adUnsignedTinyInt : Result := 'UnsignedTinyInt';
175  adSmallInt : Result := 'SmallInt';
176  adUnsignedSmallInt : Result := 'UnsignedSmallInt';
177  adInteger : Result := 'Integer';
178  adUnsignedInt : Result := 'UnsignedInt';
179  adBigInt : Result := 'BigInt';
180  adUnsignedBigInt : Result := 'UnsignedBigInt';
181  adSingle : Result := 'Single';
182  adDouble : Result := 'Double';
183  adDecimal : Result := 'Decimal';
184  adNumeric : Result := 'Numeric';
185  adVarNumeric : Result := 'VarNumeric';
186  adCurrency : Result := 'Currency';
187  adDBDate : Result := 'DBDate';
188  adDBTime : Result := 'DBTime';
189  adDate : Result := 'Date';
190  adDBTimeStamp : Result := 'DBTimeStamp';
191  adFileTime : Result := 'FileTime';
192  adLongVarChar : Result := 'LongVarChar';
193  adLongVarWChar : Result := 'LongVarWChar';
194  adBinary : Result := 'Binary';
195  adVarBinary : Result := 'VarBinary';
196  adLongVarBinary : Result := 'LongVarBinary';
197  adGUID : Result := 'GUID';
198  adEmpty : Result := 'Empty';
199  adError : Result := 'Error';
200  adArray : Result := 'Array';
201  adChapter : Result := 'Chapter';
202  adIDispatch : Result := 'IDispatch';
203  adIUnknown : Result := 'IUnknown';
204  adPropVariant : Result := 'PropVariant';
205  adUserDefined : Result := 'UserDefined';
206  adVariant : Result := 'Variant';
207  else
208  Result := 'Unknown';
209  end;
210 end;
211 
212 {**
213  Converts a Ado native types into ZDBC SQL types.
214  @param FieldType dblibc native field type.
215  @return a SQL undepended type.
216 }
217 function ConvertAdoToSqlType(const FieldType: SmallInt;
218  const CtrlsCPType: TZControlsCodePage; UseCtrsCPType: Boolean = True): TZSQLType;
219 begin
220  case FieldType of
221  adChar, adVarChar, adBSTR: Result := stString;
222  adWChar, adVarWChar: Result := stUnicodeString;
223  adBoolean: Result := stBoolean;
224 //Bug #889223, bug with tinyint on mssql
225 // adTinyInt, adUnsignedTinyInt: Result := stByte;
226  adTinyInt, adUnsignedTinyInt: Result := stShort;
227  adSmallInt, adUnsignedSmallInt: Result := stShort;
228  adInteger, adUnsignedInt: Result := stInteger;
229  adBigInt, adUnsignedBigInt: Result := stLong;
230  adSingle: Result := stFloat;
231  adDouble: Result := stDouble;
232  adDecimal: Result := stBigDecimal;
233  adNumeric, adVarNumeric: Result := stBigDecimal;
234  adCurrency: Result := stBigDecimal;
235  adDBDate: Result := stDate;
236  adDBTime: Result := stTime;
237  adDate : Result := stDate;
238  adDBTimeStamp, adFileTime: Result := stTimestamp;
239  adLongVarChar: Result := stAsciiStream;
240  adLongVarWChar: Result := stUnicodeStream;
241  adBinary, adVarBinary: Result := stBytes;
242  adLongVarBinary: Result := stBinaryStream;
243  adGUID: Result := stGUID;
244 
245  adEmpty, adError, AdArray, adChapter, adIDispatch, adIUnknown,
246  adPropVariant, adUserDefined, adVariant: Result := stString;
247  else
248  {adIDispatch, adIUnknown: reserved, nut used tpyes}Result := stUnknown
249  end;
250  if UseCtrsCPType then
251  case CtrlsCPType of
252  cCP_UTF16:
253  case Result of
254  stString: Result := stUnicodeString;
255  stAsciiStream: Result := stUnicodeStream;
256  end;
257  else
258  case Result of
259  stUnicodeString: Result := stString;
260  stUnicodeStream: Result := stAsciiStream;
261  end;
262  end;
263 end;
264 
265 {**
266  Converts a Zeos type into ADO types.
267  @param FieldType zeos field type.
268  @return a ADO datatype.
269 }
270 function ConvertSqlTypeToAdo(FieldType: TZSQLType): Integer;
271 begin
272  case FieldType of
273  stString: Result := adVarChar;
274  stUnicodeString: Result := adVarWChar;
275  stBoolean: Result := adBoolean;
276  stByte: Result := adTinyInt;
277  stShort: Result := adSmallInt;
278  stInteger: Result := adInteger;
279  stLong: Result := adBigInt;
280  stBigDecimal: Result := adDecimal;
281  stFloat: Result := adSingle;
282  stDouble: Result := adDouble;
283  stDate: Result := adDBDate;
284  stTime: Result := adDBTime;
285  stTimestamp: Result := adDBTimeStamp;
286  stBytes: Result := adVarBinary;
287  stGUID: Result := adGUID;
288  stAsciiStream: Result := adLongVarChar;
289  stUnicodeStream: Result := adLongVarWChar;
290  stBinaryStream: Result := adLongVarBinary;
291  else
292  Result := adEmpty;
293  end;
294 end;
295 
296 {**
297  Converts a Variant type into ADO types.
298  @param VT Variant datatype.
299  @return a ADO datatype.
300 }
301 {$IFDEF FPC}
302 function ConvertVariantToAdo(VT: Integer): Integer;
303 {$ELSE}
304 function ConvertVariantToAdo(VT: TVarType): Integer;
305 {$ENDIF}
306 begin
307  case VT and varTypeMask of
308  varEmpty: Result := adEmpty;
309  varNull: Result := adVarChar;
310  varSmallint: Result := adSmallInt;
311  varInteger: Result := adInteger;
312  varSingle: Result := adSingle;
313  varDouble: Result := adDouble;
314  varCurrency: Result := adCurrency;
315  varDate: Result := adDate;
316  varOleStr: Result := adVarWChar;
317  varDispatch: Result := adIDispatch;
318  varError: Result := adError;
319  varBoolean: Result := adBoolean;
320  varVariant: Result := adVariant;
321  varUnknown: Result := adIUnknown;
322 {$IFNDEF FPC}
323  varShortInt: Result := adTinyInt;
324 {$ENDIF}
325  varByte: if (VT and varArray) <> 0 then Result := adLongVarBinary else Result := adUnsignedTinyInt;
326 {$IFNDEF FPC}
327  varWord: Result := adUnsignedSmallInt;
328  varLongWord: Result := adUnsignedInt;
329  varInt64: Result := adBigInt;
330 {$ENDIF}
331  varStrArg: Result := adWChar;
332  varString: Result := adVarChar;
333 {$IFDEF UNICODE}
334  varUString: Result := adVarChar;
335 {$ENDIF}
336  varAny: Result := adEmpty;
337  else
338  Result := adEmpty;
339  end;
340 end;
341 
342 
343 {**
344  Converts a TZResultSetType type into ADO cursor type.
345  @param ResultSetType.
346  @return a ADO cursor type.
347 }
348 function ConvertResultSetTypeToAdo(ResultSetType: TZResultSetType): Integer;
349 begin
350  case ResultSetType of
351  rtForwardOnly: Result := adOpenForwardOnly;
352  rtScrollInsensitive: Result := adOpenStatic;
353  rtScrollSensitive: Result := adOpenDynamic;
354  else
355  Result := -1;//adOpenUnspecified;
356  end
357 end;
358 
359 {**
360  Converts a TZResultSetConcurrency type into ADO lock type.
361  @param ResultSetConcurrency.
362  @return a ADO lock type.
363 }
364 function ConvertResultSetConcurrencyToAdo(ResultSetConcurrency: TZResultSetConcurrency): Integer;
365 begin
366  case ResultSetConcurrency of
367  rcReadOnly: Result := adLockReadOnly;
368  rcUpdatable: Result := adLockOptimistic;
369  else
370  Result := -1;//adLockUnspecified;
371  end
372 end;
373 
374 {**
375  Converts a OLEDB schema guid into ADO schema ID usable with OpenSchema.
376  @param OleDBSchema schema guid.
377  @return a ADO schema id.
378 }
379 function ConvertOleDBToAdoSchema(OleDBSchema: TGUID): Integer;
380 begin
381  Result := -1;
382  if IsEqualGuid(OleDBSchema, DBSCHEMA_ASSERTIONS) then Result := 0;
383  if IsEqualGuid(OleDBSchema, DBSCHEMA_CATALOGS) then Result := 1;
384  if IsEqualGuid(OleDBSchema, DBSCHEMA_CHARACTER_SETS) then Result := 2;
385  if IsEqualGuid(OleDBSchema, DBSCHEMA_COLLATIONS) then Result := 3;
386  if IsEqualGuid(OleDBSchema, DBSCHEMA_COLUMNS) then Result := 4;
387  if IsEqualGuid(OleDBSchema, DBSCHEMA_CHECK_CONSTRAINTS) then Result := 5;
388  if IsEqualGuid(OleDBSchema, DBSCHEMA_CONSTRAINT_COLUMN_USAGE) then Result := 6;
389  if IsEqualGuid(OleDBSchema, DBSCHEMA_CONSTRAINT_TABLE_USAGE) then Result := 7;
390  if IsEqualGuid(OleDBSchema, DBSCHEMA_KEY_COLUMN_USAGE) then Result := 8;
391  if IsEqualGuid(OleDBSchema, DBSCHEMA_REFERENTIAL_CONSTRAINTS) then Result := 9;
392  if IsEqualGuid(OleDBSchema, DBSCHEMA_TABLE_CONSTRAINTS) then Result := 10;
393  if IsEqualGuid(OleDBSchema, DBSCHEMA_COLUMN_DOMAIN_USAGE) then Result := 11;
394  if IsEqualGuid(OleDBSchema, DBSCHEMA_INDEXES) then Result := 12;
395  if IsEqualGuid(OleDBSchema, DBSCHEMA_COLUMN_PRIVILEGES) then Result := 13;
396  if IsEqualGuid(OleDBSchema, DBSCHEMA_TABLE_PRIVILEGES) then Result := 14;
397  if IsEqualGuid(OleDBSchema, DBSCHEMA_USAGE_PRIVILEGES) then Result := 15;
398  if IsEqualGuid(OleDBSchema, DBSCHEMA_PROCEDURES) then Result := 16;
399  if IsEqualGuid(OleDBSchema, DBSCHEMA_SCHEMATA) then Result := 17;
400  if IsEqualGuid(OleDBSchema, DBSCHEMA_SQL_LANGUAGES) then Result := 18;
401  if IsEqualGuid(OleDBSchema, DBSCHEMA_STATISTICS) then Result := 19;
402  if IsEqualGuid(OleDBSchema, DBSCHEMA_TABLES) then Result := 20;
403  if IsEqualGuid(OleDBSchema, DBSCHEMA_TRANSLATIONS) then Result := 21;
404  if IsEqualGuid(OleDBSchema, DBSCHEMA_PROVIDER_TYPES) then Result := 22;
405  if IsEqualGuid(OleDBSchema, DBSCHEMA_VIEWS) then Result := 23;
406  if IsEqualGuid(OleDBSchema, DBSCHEMA_VIEW_COLUMN_USAGE) then Result := 24;
407  if IsEqualGuid(OleDBSchema, DBSCHEMA_VIEW_TABLE_USAGE) then Result := 25;
408  if IsEqualGuid(OleDBSchema, DBSCHEMA_PROCEDURE_PARAMETERS) then Result := 26;
409  if IsEqualGuid(OleDBSchema, DBSCHEMA_FOREIGN_KEYS) then Result := 27;
410  if IsEqualGuid(OleDBSchema, DBSCHEMA_PRIMARY_KEYS) then Result := 28;
411  if IsEqualGuid(OleDBSchema, DBSCHEMA_PROCEDURE_COLUMNS) then Result := 29;
412  if IsEqualGuid(OleDBSchema, MDSCHEMA_CUBES) then Result := 32;
413  if IsEqualGuid(OleDBSchema, MDSCHEMA_DIMENSIONS) then Result := 33;
414  if IsEqualGuid(OleDBSchema, MDSCHEMA_HIERARCHIES) then Result := 34;
415  if IsEqualGuid(OleDBSchema, MDSCHEMA_LEVELS) then Result := 35;
416  if IsEqualGuid(OleDBSchema, MDSCHEMA_MEASURES) then Result := 36;
417  if IsEqualGuid(OleDBSchema, MDSCHEMA_PROPERTIES) then Result := 37;
418  if IsEqualGuid(OleDBSchema, MDSCHEMA_MEMBERS) then Result := 38;
419  if IsEqualGuid(OleDBSchema, DBPROPSET_TRUSTEE) then Result := 39;
420 end;
421 
422 {**
423  Brings up the ADO connection string builder dialog.
424 }
425 function PromptDataSource(Handle: THandle; InitialString: WideString): WideString;
426 var
427  DataInit: IDataInitialize;
428  DBPrompt: IDBPromptInitialize;
429  DataSource: IUnknown;
430  InitStr: PWideChar;
431 begin
432  Result := InitialString;
433  DataInit := CreateComObject(CLSID_DataLinks) as IDataInitialize;
434  if InitialString <> '' then
435  DataInit.GetDataSource(nil, CLSCTX_INPROC_SERVER,
436  PWideChar(InitialString), IUnknown, DataSource);
437  DBPrompt := CreateComObject(CLSID_DataLinks) as IDBPromptInitialize;
438  if Succeeded(DBPrompt.PromptDataSource(nil, Handle,
439  DBPROMPTOPTIONS_PROPERTYSHEET, 0, nil, nil, IUnknown, DataSource)) then
440  begin
441  InitStr := nil;
442  DataInit.GetInitializationString(DataSource, True, InitStr);
443  Result := InitStr;
444  end;
445 end;
446 
447 function GetCurrentResultSet(AdoRecordSet: ZPlainAdo.RecordSet;
448  Connection: IZAdoConnection; Statement: IZStatement; Const SQL: String; ConSettings: PZConSettings;
449  const ResultSetConcurrency: TZResultSetConcurrency): IZResultSet;
450 var
451  NativeResultSet: IZResultSet;
452 begin
453  Result := nil;
454  if Assigned(AdoRecordset) then
455  if (AdoRecordSet.State and adStateOpen) = adStateOpen then
456  begin
457  NativeResultSet := TZAdoResultSet.Create(Statement, SQL, AdoRecordSet);
458  if ResultSetConcurrency = rcUpdatable then
459  Result := TZCachedResultSet.Create(NativeResultSet, SQL,
460  TZAdoCachedResolver.Create(Connection.GetAdoConnection,
461  Statement, NativeResultSet.GetMetaData), ConSettings)
462  else
463  Result := NativeResultSet;
464  end;
465 end;
466 
467 function IsSelect(const SQL: string): Boolean;
468 begin
469  Result := Uppercase(Copy(TrimLeft(Sql), 1, 6)) = 'SELECT';
470 end;
471 
472 {**
473  Sets a variant value into specified parameter.
474  @param AdoCommand the ole command
475  @param Connection the Connection interface
476  @param ParameterIndex a index of the parameter.
477  @param SqlType a parameter SQL type.
478  @paran Value a new parameter value.
479 }
480 procedure ADOSetInParam(AdoCommand: ZPlainAdo.Command; Connection: IZConnection;
481  ParamCount: Integer; const ParameterIndex: Integer;
482  const SQLType: TZSQLType; const Value: TZVariant;
483  const ParamDirection: ParameterDirectionEnum);
484 var
485  S: Integer;
486  B: IZBlob;
487  V: OleVariant;
488  T: Integer;
489  P: ZPlainAdo.Parameter;
490  RetValue: TZVariant;
491  TmpSQLType: TZSQLType;
492 begin
493  RetValue:= Value;
494  TmpSQLType := SQLType;
495  if not (RetValue.VType = vtNull) and (RetValue.VType = vtInterface) and
496  (SQLType in [stAsciiStream, stUnicodeStream, stBinaryStream]) then
497  begin
498  B := DefVarManager.GetAsInterface(Value) as IZBlob;
499  if B.IsEmpty then
500  RetValue := NullVariant
501  else
502  case SQLType of
503  stAsciiStream:
504  begin
505  {$IFDEF UNICODE}
506  DefVarManager.SetAsString(RetValue, String(B.GetString));
507  {$ELSE}
508  DefVarManager.SetAsString(RetValue, GetValidatedAnsiStringFromBuffer(B.GetBuffer, B.Length, Connection.GetConSettings));
509  {$ENDIF}
510  TmpSQLType := stString;
511  end;
512  stUnicodeStream:
513  begin
514  if B.Connection = nil then
515  B := TZAbstractBlob.CreateWithData(B.GetBuffer, B.Length, Connection, B.WasDecoded);
516  DefVarManager.SetAsUnicodeString(RetValue, B.GetUnicodeString);
517  TmpSQLType := stUnicodeString;
518  end;
519  stBinaryStream:
520  begin
521  if Assigned(B) then
522  DefVarManager.SetAsBytes(RetValue, B.GetBytes);
523  TmpSQLType := stBytes;
524  end;
525  end;
526  end;
527 
528  case RetValue.VType of
529  vtNull: V := Null;
530  vtBoolean: V := SoftVarManager.GetAsBoolean(RetValue);
531  vtBytes: V := SoftVarManager.GetAsBytes(RetValue);
532  vtInteger: //V := SoftVarManager.GetAsInteger(RetValue);
533  begin //Hacking the IDE variant: Not all IDE's support
534  P := AdoCommand.Parameters.Item[ParameterIndex - 1];
535  P.Value := SoftVarManager.GetAsInteger(RetValue);
536  P.Type_ := adBigInt;
537  P.Direction := ParamDirection;
538  Exit;
539  end;
540  vtFloat: V := SoftVarManager.GetAsFloat(RetValue);
541  vtString:
542  {$IFDEF UNICODE}
543  V := SoftVarManager.GetAsString(RetValue);
544  {$ELSE}
545  if ParamDirection = adParamInputOutput then //can't say why but bidirectional params need to be converted first.
546  //On the other hand they where not refreshed after second call! Is there a problem with Variant vs. OleVariant and strings?
547  begin
548  V := WideString(SoftVarManager.GetAsString(RetValue));
549  TmpSQLType := stUnicodeString;
550  end
551  else
552  if SQLType = stAsciiStream then
553  V := SoftVarManager.GetAsString(RetValue)
554  else
555  V := Connection.GetIZPlainDriver.ZPlainString(SoftVarManager.GetAsString(RetValue), Connection.GetConSettings);
556  {$ENDIF}
557  vtUnicodeString: V := WideString(SoftVarManager.GetAsUnicodeString(RetValue));
558  vtDateTime: V := TDateTime(SoftVarManager.GetAsDateTime(RetValue));
559  end;
560 
561  S := 0; //init val
562  case TmpSQLType of
563  stString:
564  begin
565  S := Length(VarToStr(V));
566  if S = 0 then S := 1;
567  //V := Null; patch by zx - see http://zeos.firmos.at/viewtopic.php?t=1255
568  end;
569  stUnicodeString:
570  begin
571  S := Length(VarToWideStr(V))*2; //strange! Need size in bytes!!
572  if S = 0 then S := 1;
573  //V := Null; patch by zx - see http://zeos.firmos.at/viewtopic.php?t=1255
574  end;
575  stBytes:
576  begin
577  //V := StrToBytes(VarToStr(V));
578  if (VarType(V) and varArray) <> 0 then
579  S := VarArrayHighBound(V, 1) + 1;
580  if S = 0 then V := Null;
581  end;
582  end;
583 
584  if VarIsNull(V) or (SQLType = stBytes) then
585  T := ConvertSqlTypeToAdo(TmpSQLType)
586  else
587  T := ConvertVariantToAdo(VarType(V));
588 
589  if ParameterIndex <= ParamCount then
590  begin
591  P := AdoCommand.Parameters.Item[ParameterIndex - 1];
592  P.Direction := ParamDirection; //set ParamDirection! Bidirection is requires for callables f.e.
593  if not VarIsNull(V) then //align new size and type
594  begin
595  P.Type_ := T;
596  P.Size := S;
597  end;
598  if VarIsClear(P.Value) or (P.Value <> V) or (TmpSQLType = stBytes) then //Check if Param is cleared, unasigned or different
599  P.Value := V;
600  end
601  else
602  AdoCommand.Parameters.Append(AdoCommand.CreateParameter(
603  'P' + IntToStr(ParameterIndex), T, ParamDirection, S, V));
604 end;
605 
606 procedure RefreshParameters(AdoCommand: ZPlainAdo.Command;
607  DirectionTypes: PDirectionTypes = nil);
608  procedure RefreshFromOleDB;
609  var
610  I: Integer;
611  ParamCount: NativeUInt;
612  ParamInfo: PDBParamInfoArray;
613  NamesBuffer: POleStr;
614  Name: WideString;
615  Parameter: _Parameter;
616  Direction: ParameterDirectionEnum;
617  OLEDBCommand: ICommand;
618  OLEDBParameters: ICommandWithParameters;
619  CommandPrepare: ICommandPrepare;
620  begin
621  OLEDBCommand := (AdoCommand as ADOCommandConstruction).OLEDBCommand as ICommand;
622  OLEDBCommand.QueryInterface(ICommandWithParameters, OLEDBParameters);
623  OLEDBParameters.SetParameterInfo(0, nil, nil);
624  if Assigned(OLEDBParameters) then
625  begin
626  ParamInfo := nil;
627  NamesBuffer := nil;
628  try
629  OLEDBCommand.QueryInterface(ICommandPrepare, CommandPrepare);
630  if Assigned(CommandPrepare) then CommandPrepare.Prepare(0);
631  if OLEDBParameters.GetParameterInfo(ParamCount, PDBPARAMINFO(ParamInfo), @NamesBuffer) = S_OK then
632  for I := 0 to ParamCount - 1 do
633  with ParamInfo[I] do
634  begin
635  { When no default name, fabricate one like ADO does }
636  if pwszName = nil then
637  Name := 'Param' + IntToStr(I+1) else { Do not localize }
638  Name := pwszName;
639  { ADO maps DBTYPE_BYTES to adVarBinary }
640  if wType = DBTYPE_BYTES then wType := adVarBinary;
641  { ADO maps DBTYPE_STR to adVarChar }
642  if wType = DBTYPE_STR then wType := adVarChar;
643  { ADO maps DBTYPE_WSTR to adVarWChar }
644  if wType = DBTYPE_WSTR then wType := adVarWChar;
645  Direction := dwFlags and $F;
646  { Verify that the Direction is initialized }
647  if Assigned(DirectionTypes) then
648  Parameter := AdoCommand.CreateParameter(Name, wType, DirectionTypes^[i], ulParamSize, EmptyParam)
649  else
650  begin
651  if Direction = adParamUnknown then Direction := adParamInput;
652  Parameter := AdoCommand.CreateParameter(Name, wType, Direction, ulParamSize, EmptyParam);
653  end;
654  Parameter.Precision := bPrecision;
655  Parameter.NumericScale := ParamInfo[I].bScale;
656  Parameter.Attributes := dwFlags and $FFFFFFF0; { Mask out Input/Output flags }
657  end;
658  finally
659  if Assigned(CommandPrepare) then CommandPrepare.Unprepare;
660  if (ParamInfo <> nil) then ZAdoMalloc.Free(ParamInfo);
661  if (NamesBuffer <> nil) then ZAdoMalloc.Free(NamesBuffer);
662  end;
663  end;
664  end;
665 
666  procedure RefreshFromADO;
667  var
668  I: Integer;
669  Parameter: _Parameter;
670  begin
671  with AdoCommand do
672  try
673  Parameters.Refresh;
674  for I := 0 to Parameters.Count - 1 do
675  with Parameters[I] do
676  begin
677  { We can't use the instance of the parameter in the ADO collection because
678  it will be freed when the connection is closed even though we have a
679  reference to it. So instead we create our own and copy the settings }
680  if Assigned(DirectionTypes) then
681  Parameter := CreateParameter(Name, Type_, DirectionTypes^[i], Size, EmptyParam)
682  else
683  Parameter := CreateParameter(Name, Type_, Direction, Size, EmptyParam);
684  Parameter.Precision := Precision;
685  Parameter.NumericScale := NumericScale;
686  Parameter.Attributes := Attributes;
687  end;
688  except
689  { do nothing }
690  end;
691  end;
692 begin
693  if ( AdoCommand.CommandType = adCmdText ) then
694  RefreshFromOLEDB else
695  RefreshFromADO;
696 end;
697 
698 initialization
699  OleCheck(CoGetMalloc(1, ZAdoMalloc));
700 finalization
701  ZAdoMalloc := nil;
702 end.
703 
704