Автор: Delirium
WEB-сайт: http://delphibase.endimus.com

{ **** UBPFD *********** by delphibase.endimus.com ****
>> Модуль, содержащий несколько удобств для работы с MSSQL посредством ADO

Зависимости: Windows, Classes, SysUtils, ADODB, ADOInt, ActiveX, Controls, Variants, ComObj
Автор: Delirium, Master_BRAIN@beep.ru, ICQ:118395746, Москва
Copyright: Delirium
Дата: 30 апреля 2002 г.
***************************************************** }

unit ThADO;

interface

uses Windows, Classes, SysUtils, ADODB, ADOInt, ActiveX, Controls, Variants,
 ComObj;

type
 // Процедура для передачи событий
 TThreadADOQueryOnAfterWork = procedure(AHandle: THandle; RecordSet:
 _RecordSet; Active: Boolean) of object;
 // Вспомогательный класс
 TThADOQuery = class(TThread)
 private
 ADOQuery: TADOQuery;
 FAfterWork: TThreadADOQueryOnAfterWork;

 protected
 procedure DoWork;
 procedure Execute; override;

 public
 constructor Create;

 published
 property OnAfterWork: TThreadADOQueryOnAfterWork read FAfterWork write
 FAfterWork;
 end;
 // Класс для асинхронного получения информации посредством ADO
 TThreadADOQuery = class(TObject)
 private
 FAfterWork: TThreadADOQueryOnAfterWork;
 FActive: Boolean;
 FQuery: TThADOQuery;
 FHandle: THandle;

 protected
 procedure AfterWork(AHandle: THandle; RecordSet: _RecordSet; Active:
 Boolean);

 public
 constructor Create(aConnectionString: string);

 // Запустить запрос на исполнение
 // (если Batch=True - LockType=ltBatchOptimistic)
 procedure StartWork(aSQL: string; Batch: boolean = False);
 // Приостановить / продолжить исполнение запроса (True - если "на паузе")
 function PauseWork: boolean;
 // Остановить исполнение запроса (возможны потери памяти)
 procedure StopWork;

 published
 property Active: Boolean read FActive;
 property Handle: THandle read FHandle;
 property OnAfterWork: TThreadADOQueryOnAfterWork read FAfterWork write
 FAfterWork;
 end;

 // Интеграция рекордсета во временую или постоянную таблицу для MSSQL
function RecordSetToTempTableForMSSQL(Connection: TADOConnection; RecordSet:
 _RecordSet; TableName: string): boolean;
// Сохранение рекордсета в файл формата DBF, для организации локальной БД
function RecordSetToDBF(RecordSet: _RecordSet; FileName: string): boolean;
// "Физическое" клонирование рекордсетов
function CopyRecordSet(RecordSet: _RecordSet): _RecordSet;
//Функция, генерирует уникальное имя для таблиц (или файлов)
function UniqueTableName: string;

implementation

var
 FConnectionString, FSQL: string;
 FBatch: boolean;

constructor TThADOQuery.Create;
begin
 inherited Create(True);
 FreeOnTerminate := True;
end;

procedure TThADOQuery.Execute;
begin
 CoInitializeEx(nil, COINIT_MULTITHREADED);
 // Создал Query
 ADOQuery := TADOQuery.Create(nil);
 ADOQuery.CommandTimeout := 0;
 ADOQuery.ConnectionString := FConnectionString;
 // загружаю скрипт
 if Pos('FILE NAME=', AnsiUpperCase(FSQL)) = 1 then
 ADOQuery.SQL.LoadFromFile(Copy(FSQL, 11, Length(FSQL)))
 else
 ADOQuery.SQL.Text := FSQL;
 // Попытка исполнить запрос
 try
 if FBatch then
 ADOQuery.LockType := ltBatchOptimistic
 else
 ADOQuery.LockType := ltOptimistic;
 ADOQuery.Open;
 except
 end;
 // Обрабатываю событие
 Synchronize(DoWork);
 // Убиваю Query
 ADOQuery.Close;
 ADOQuery.Free;
 CoUninitialize;
end;

procedure TThADOQuery.DoWork;
begin
 FAfterWork(Self.Handle, ADOQuery.Recordset, ADOQuery.Active);
end;

constructor TThreadADOQuery.Create(aConnectionString: string);
begin
 inherited Create;
 FActive := False;
 FConnectionString := aConnectionString;
 FHandle := 0;
end;

procedure TThreadADOQuery.StartWork(aSQL: string; Batch: boolean = False);
begin
 if not Assigned(Self) then
 exit;
 FActive := True;
 FQuery := TThADOQuery.Create;
 FHandle := FQuery.Handle;
 FQuery.OnAfterWork := AfterWork;
 FSQL := aSQL;
 FBatch := Batch;
 FQuery.ReSume;
end;

procedure TThreadADOQuery.AfterWork(AHandle: THandle; RecordSet: _RecordSet;
 Active: Boolean);
begin
 if Assigned(Self) and Assigned(FAfterWork) then
 FAfterWork(FHandle, Recordset, Active);
 FActive := False;
end;

function TThreadADOQuery.PauseWork: boolean;
begin
 if Assigned(Self) and FActive then
 FQuery.Suspended := not FQuery.Suspended;
 Result := FQuery.Suspended;
end;

procedure TThreadADOQuery.StopWork;
var
 c: Cardinal;
begin
 c := 0;
 if Assigned(Self) and FActive then
 begin
 TerminateThread(FHandle, c);
 FQuery.ADOQuery.Free;
 FQuery.Free;
 end;
 FActive := False;
end;

function RecordSetToTempTableForMSSQL(Connection: TADOConnection; RecordSet:
 _RecordSet; TableName: string): boolean;
var
 i: integer;
 S, L: string;
 TempQuery: TADOQuery;
begin
 Result := True;
 try
 S := '-- Script generated by Master BRAIN 2002 (C) --' + #13;
 S := S + 'IF OBJECT_ID(''TEMPDB..' + TableName +
 ''') IS NOT NULL DROP TABLE ' + TableName + #13;
 S := S + 'IF OBJECT_ID(''' + TableName + ''') IS NOT NULL DROP TABLE ' +
 TableName + #13;
 S := S + 'CREATE TABLE ' + TableName + ' (' + #13;
 for i := 0 to RecordSet.Fields.Count - 1 do
 begin
 case RecordSet.Fields.Item[i].Type_ of
 adSmallInt, adUnsignedSmallInt: L := 'SMALLINT';
 adTinyInt, adUnsignedTinyInt: L := 'TINYINT';
 adInteger, adUnsignedInt: L := 'INT';
 adBigInt, adUnsignedBigInt: L := 'BIGINT';
 adSingle, adDouble, adDecimal,
 adNumeric: L := 'NUMERIC(' +
 IntToStr(RecordSet.Fields.Item[i].Precision) + ',' +
 IntToStr(RecordSet.Fields.Item[i].NumericScale) + ')';
 adCurrency: L := 'MONEY';
 adBoolean: L := 'BIT';
 adGUID: L := 'UNIQUEIDENTIFIER';
 adDate, adDBDate, adDBTime,
 adDBTimeStamp: L := 'DATETIME';
 adChar: L := 'CHAR(' + IntToStr(RecordSet.Fields.Item[i].DefinedSize) +
 ')';
 adBSTR: L := 'NCHAR(' + IntToStr(RecordSet.Fields.Item[i].DefinedSize) +
 ')';
 adVarChar: L := 'VARCHAR(' +
 IntToStr(RecordSet.Fields.Item[i].DefinedSize) + ')';
 adVarWChar: L := 'NVARCHAR(' +
 IntToStr(RecordSet.Fields.Item[i].DefinedSize) + ')';
 adLongVarChar: L := 'TEXT';
 adLongVarWChar: L := 'NTEXT';
 adBinary: L := 'BINARY(' + IntToStr(RecordSet.Fields.Item[i].DefinedSize)
 + ')';
 adVarBinary: L := 'VARBINARY(' +
 IntToStr(RecordSet.Fields.Item[i].DefinedSize) + ')';
 adLongVarBinary: L := 'IMAGE';
 adFileTime, adDBFileTime: L := 'TIMESTAMP';
 else
 L := 'SQL_VARIANT';
 end;
 S := S + RecordSet.Fields.Item[i].Name + ' ' + L;
 if i < RecordSet.Fields.Count - 1 then
 S := S + ' ,' + #13
 else
 S := S + ' )' + #13;
 end;
 S := S + 'SELECT * FROM ' + TableName + #13;
 TempQuery := TADOQuery.Create(nil);
 TempQuery.Close;
 TempQuery.LockType := ltBatchOptimistic;
 TempQuery.SQL.Text := S;
 TempQuery.Connection := Connection;
 TempQuery.Open;
 RecordSet.MoveFirst;
 while not RecordSet.EOF do
 begin
 TempQuery.Append;
 for i := 0 to RecordSet.Fields.Count - 1 do
 TempQuery.FieldValues[RecordSet.Fields[i].Name] :=
 RecordSet.Fields[i].Value;
 TempQuery.Post;
 RecordSet.MoveNext;
 end;
 TempQuery.UpdateBatch;
 TempQuery.Close;
 except
 Result := False;
 end;
end;

function RecordSetToDBF(RecordSet: _RecordSet; FileName: string): boolean;
var
 F_sv: TextFile;
 i, j, s, sl, iRowCount, iColCount: integer;
 l: string;
 Fields: array of record
 FieldType: Char;
 FieldSize, FieldDigits: byte;
 end;
 FieldType, tmpDC: Char;
 FieldSize, FieldDigits: byte;

 // Нестандартная конвертация - без глюков
 function Ansi2OEM(S: string): string;
 var
 Ansi_CODE, OEM_CODE: string;
 i: integer;
 begin
 OEM_CODE :=
 'ЂЃ‚ѓ„…†‡€‰Љ‹ЊЌЋЏђ‘’“”•–—˜™љ›њќћџ ЎўЈ¤Ґ¦§Ё©Є«¬­®Їабвгдежзийклмнопьс';
 Ansi_CODE :=
 'АБВГДЕЖЗИЙКЛМНОПРСТУФХЦЧШЩЪЫЬЭЮЯабвгдежзийклмнопрстуфхцчшщъыьэюя№ё';
 Result := S;
 for i := 1 to Length(Result) do
 if Pos(Result[i], Ansi_CODE) > 0 then
 Result[i] := OEM_CODE[Pos(Result[i], Ansi_CODE)];
 end;

begin
 Result := True;
 try
 AssignFile(F_sv, FileName);
 ReWrite(F_sv);
 iRowCount := RecordSet.RecordCount;
 iColCount := RecordSet.Fields.Count;
 // Формат dBASE III 2.0
 Write(F_sv, #3 + chr($63) + #4 + #4); // Заголовок 4 байта
 write(F_sv, Chr((((iRowCount) mod 16777216) mod 65536) mod 256) +
 Chr((((iRowCount) mod 16777216) mod 65536) div 256) +
 Chr(((iRowCount) mod 16777216) div 65536) +
 Chr((iRowCount) div 16777216)); // Word32 -> кол-во строк 5-8 байты

 i := (iColCount + 1) * 32 + 1; // Изврат
 write(F_sv, Chr(i mod 256) +
 Chr(i div 256)); // Word16 -> кол-во колонок с извратом 9-10 байты

 S := 1; // Считаем длинну загаловка
 for i := 0 to iColCount - 1 do
 begin
 if RecordSet.Fields[i].Precision = 255 then
 Sl := RecordSet.Fields[i].DefinedSize
 else
 Sl := RecordSet.Fields[i].Precision;
 if RecordSet.Fields.Item[i].Type_ in [adDate, adDBDate, adDBTime,
 adFileTime, adDBFileTime, adDBTimeStamp] then
 Sl := 8;
 S := S + Sl;
 end;

 write(F_sv, Chr(S mod 256) + Chr(S div 256)); { пишем длину заголовка 11-12}
 for i := 1 to 17 do
 write(F_sv, #0); // Пишем всякий хлам - 20 байт
 write(F_sv, chr($26) + #0 + #0); // Итого: 32 байта - базовый заголовок DBF

 SetLength(Fields, iColCount);
 for i := 0 to iColCount - 1 do
 begin // заполняем заголовок, а за одно и массив полей
 l := Copy(RecordSet.Fields[i].Name, 1, 10); // имя колонки
 while Length(l) < 11 do
 l := l + #0;
 write(F_sv, l);
 case RecordSet.Fields.Item[i].Type_ of
 adTinyInt, adSmallInt, adInteger, adBigInt, adUnsignedTinyInt,
 adUnsignedSmallInt, adUnsignedInt, adUnsignedBigInt,
 adDecimal, adNumeric, adVarNumeric, adSingle, adDouble: FieldType :=
 'N';
 adCurrency: FieldType := 'F';
 adDate, adDBDate, adDBTime, adFileTime, adDBFileTime, adDBTimeStamp:
 FieldType := 'D';
 adBoolean: FieldType := 'L';
 else
 FieldType := 'C';
 end;
 Fields[i].FieldType := FieldType;

 if RecordSet.Fields[i].Precision = 255 then
 FieldSize := RecordSet.Fields[i].DefinedSize
 else
 FieldSize := RecordSet.Fields[i].Precision;

 if Fields[i].FieldType = 'D' then
 Fields[i].FieldSize := 8
 else
 Fields[i].FieldSize := FieldSize;

 if RecordSet.Fields[i].NumericScale = 255 then
 FieldDigits := 0
 else
 FieldDigits := RecordSet.Fields[i].NumericScale;
 if (FieldType = 'F') and (FieldDigits < 2) then
 FieldDigits := 2;
 Fields[i].FieldDigits := FieldDigits;

 write(F_sv, FieldType + #0 + #0 + #0 + #0); // теперь размер
 write(F_sv, Chr(FieldSize) + Chr(FieldDigits));
 write(F_sv, #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0 + #0
 + #0); // 14 нулей
 end;
 write(F_sv, Chr($0D)); // разделитель

 tmpDC := DECIMALSEPARATOR;
 DECIMALSEPARATOR := '.'; // Числа в англицком формате
 if iRowCount > 1 then
 RecordSet.MoveFirst;
 for j := 0 to iRowCount - 1 do
 begin // пишем данные
 write(F_sv, ' ');
 for i := 0 to iColCount - 1 do
 begin
 case Fields[i].FieldType of
 'D': if not VarIsNull(RecordSet.Fields[i].Value) then
 L := FormatDateTime('yyyymmdd',
 VarToDateTime(RecordSet.Fields[i].Value))
 else
 L := '1900101';
 'N', 'F': if not VarIsNull(RecordSet.Fields[i].Value) then
 L := Format('%' + IntToStr(Fields[i].FieldSize -
 Fields[i].FieldDigits) + '.' + IntToStr(Fields[i].FieldDigits) +
 'f', [StrToFloatDef(VarToStr(RecordSet.Fields[i].Value), 0)])
 else
 L := '';
 else if not VarIsNull(RecordSet.Fields[i].Value) then
 L := Ansi2Oem(VarToStr(RecordSet.Fields[i].Value))
 else
 L := '';
 end;

 while Length(L) < Fields[i].FieldSize do
 if Fields[i].FieldType in ['N', 'F'] then
 L := L + #0
 else
 L := L + ' ';
 if Length(L) > Fields[i].FieldSize then
 SetLength(L, Fields[i].FieldSize);

 write(F_sv, l);
 end;

 RecordSet.MoveNext;
 end;
 DECIMALSEPARATOR := tmpDC;
 write(F_sv, Chr($1A));
 CloseFile(F_sv);
 except
 Result := False;
 if FileExists(FileName) then
 DeleteFile(FileName);
 end;
end;

function CopyRecordSet(RecordSet: _RecordSet): _RecordSet;
var
 adoStream: OleVariant;
begin
 adoStream := CreateOLEObject('ADODB.Stream');
 Variant(RecordSet).Save(adoStream, adPersistADTG);
 Result := CreateOLEObject('ADODB.RecordSet') as _RecordSet;
 Result.CursorLocation := adUseClient;
 Result.Open(adoStream, EmptyParam, adOpenStatic, adLockOptimistic,
 adOptionUnspecified);
 adoStream := UnAssigned;
end;

function UniqueTableName: string;
var
 G: TGUID;
begin
 CreateGUID(G);
 Result := GUIDToString(G);
 Delete(Result, 1, 1);
 Delete(Result, Length(Result), 1);
 while Pos('-', Result) > 0 do
 Delete(Result, Pos('-', Result), 1);
 Result := 'T' + Result;
end;

end.