Delphi World - Модуль, содержащий несколько удобств для работы с MSSQL посредством ADO
Delphi World - это проект, являющийся сборником статей и малодокументированных возможностей  по программированию в среде Delphi. Здесь вы найдёте работы по следующим категориям: delphi, delfi, borland, bds, дельфи, делфи, дэльфи, дэлфи, programming, example, программирование, исходные коды, code, исходники, source, sources, сорцы, сорсы, soft, programs, программы, and, how, delphiworld, базы данных, графика, игры, интернет, сети, компоненты, классы, мультимедиа, ос, железо, программа, интерфейс, рабочий стол, синтаксис, технологии, файловая система...
Модуль, содержащий несколько удобств для работы с MSSQL посредством ADO

Автор: 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.
Проект Delphi World © Выпуск 2002 - 2017
Автор проекта: Эксклюзивные курсы программирования