adoquery.parameters流化

unit WebAdoStream;

{****************************************************************

        单元名称：WebAdoStream.pas

        创建日期：2009-10-01

        创建者    本模块改编于 New Midas VCL Library(1.00)的JxStream.pas

        功能:     

        当前版本：

        Email：dcopyboy@tom.com

        QQ:445235526

 

***************************************************************}

interface

 

uses Windows, Classes, SysUtils, SqlTimSt, FMTBcd, Variants, db, adodb;

 

type

  // 存贮版本错误.

  EPersistVersion = class(Exception);

  EPersistError = class(Exception);

  EClassNotFound = class(EPersistError);

  EWriterError = class(EPersistError);

  EReaderError = class(EPersistError);

  // Unicode编码类型.

  TStrTransferFormat = (tfUtf16LE, tfUtf16BE, tfUtf8);

  // 数据写入(以小端格式写入)

  TWAStreamWriter = class

  private

    FStream: TStream;

    FTransferFormat: TStrTransferFormat; // 未用

    procedure Write7BitEncodedInt(value: LongInt);

    // 写入shortstring. 适用于写入ClassName, 因为这些属性以

    // ShortString存在, 如果转换为String再写入, 则多了构造

    // String的步骤, 速度较慢

    procedure WriteShortString(const value: ShortString);

  public

    property Stream: TStream read FStream write FStream;

    property TransferFormat: TStrTransferFormat read FTransferFormat write FTransferFormat;

    procedure WriteBuffer(const Buffer; Count: Longint);

    procedure WriteShortInt(value: ShortInt);

    procedure WriteSmallInt(value: SmallInt);

    procedure WriteLongInt(value: LongInt);

    procedure WriteInt64(value: Int64);

    procedure WriteByte(value: Byte);

    procedure WriteWord(value: Word);

    procedure WriteLongWord(value: LongWord);

    procedure WriteCurrency(value: Currency);

    procedure WriteSingle(value: Single);

    procedure WriteDouble(value: Double);

    procedure WriteBool(value: Boolean);

    procedure WriteDateTime(value: TDateTime);

    procedure WriteAscii(value: string);

    procedure WriteString(value: string);

    procedure WriteOleString(value: WideString);

    procedure WriteBinary(const Buffer; Size: Integer);

    procedure WriteTimeStamp(const ATimeStamp: TSqlTimeStamp);

    procedure WriteFMTBcd(const ABcd: TBcd);

    procedure WriteVariant(const V: Variant);

    procedure WriteObjectProps(Obj: TPersistent);

  end;

 

  // 数据读取(以小端读取)

  TWAStreamReader = class

  private

    FStream: TStream;

    FTransferFormat: TStrTransferFormat;

    function Read7BitEncodedInt: LongInt;

    function ReadShortString: string;

  public

    property Stream: TStream read FStream write FStream;

    property TransferFormat: TStrTransferFormat read FTransferFormat write FTransferFormat;

    procedure ReadBuffer(var Buffer; Count: Longint);

    function ReadShortInt: ShortInt;

    function ReadSmallInt: SmallInt;

    function ReadLongInt: LongInt;

    function ReadInt64: Int64;

    function ReadByte: Byte;

    function ReadWord: Word;

    function ReadLongWord: LongWord;

    function ReadCurrency: Currency;

    function ReadSingle: Single;

    function ReadDouble: Double;

    function ReadBool: Boolean;

    function ReadDateTime: TDateTime;

    // 读取ASCII字符串, 长度<=255, 多则截断.

    function ReadAscii(len: Byte): string;

    function ReadString: string;

    function ReadOleString: WideString;

    function ReadBinary: string;

    function ReadStream: TStream;

    procedure ReadTimeStamp(var ATimeStamp: TSqlTimeStamp);

    procedure ReadFMTBcd(var ABcd: TBcd);

    function ReadVariant: Variant;

    procedure ReadObjectProps(Obj: TPersistent);

  end;

function AdoQuerySaveTostream(Adoq: Tadoquery): TMemoryStream;

function AdoQueryLoadFromstream(Adoq: Tadoquery; Stream: TMemoryStream): boolean;

 

implementation

uses TypInfo;

 

resourcestring

  SInvalidVariantType = '无效的Variant类型 %d';

  SClassNotFound = 'class %s not found.';

  SWriterError = 'Stream write error.';

  SReaderError = 'Stream read error.';

  SPersistClassError = 'Persistable class not supported.';

  SPersistTypeNotSupported = 'Type %s not supported';

 

type

  PIntArray = ^TIntArray;

  TIntArray = array[0..0] of Integer;

 

const

  SimpleArrayTypes = [varSmallInt, varInteger, varSingle, varDouble, varCurrency,

    varDate, varBoolean, varShortInt, varByte, varWord, varLongWord];

 

  VariantSize: array[0..varLongWord] of Word = (0, 0, SizeOf(SmallInt), SizeOf(Integer),

    SizeOf(Single), SizeOf(Double), SizeOf(Currency), SizeOf(TDateTime), 0, 0,

    SizeOf(Integer), SizeOf(WordBool), 0, 0, 0, 0, SizeOf(ShortInt), SizeOf(Byte),

    SizeOf(Word), SizeOf(LongWord));

 

  CMinVarType = $100;

  StreamFMTBcdID = CMinVarType + 1;

  StreamSQLTimeStampID = CMinVarType + 2;

 

 

{ TWAStreamWriter }

 

procedure TWAStreamWriter.Write7BitEncodedInt(value: Integer);

begin

  while value > $80 do

  begin

    WriteByte(Byte(value or $80));

    value := value shr 7;

  end;

  WriteByte(value and $FF);

end;

 

procedure TWAStreamWriter.WriteAscii(value: string);

var

  len: Integer;

begin

  len := Length(value);

  if len > 255 then

    len := 255;

  if len > 0 then WriteBuffer(PChar(value)^, len);

end;

 

procedure TWAStreamWriter.WriteBinary(const Buffer; Size: Integer);

begin

  Write7BitEncodedInt(Size);

  WriteBuffer(Buffer, Size);

end;

 

procedure TWAStreamWriter.WriteBool(value: Boolean);

begin

  if value then

    WriteByte(1)

  else

    WriteByte(0);

end;

 

procedure TWAStreamWriter.WriteBuffer(const Buffer; Count: Integer);

begin

  if (Count <> 0) and (Stream.Write(Buffer, Count) <> Count) then

    raise EWriterError.Create(SWriterError);

end;

 

procedure TWAStreamWriter.WriteByte(value: Byte);

begin

  WriteBuffer(value, 1);

end;

 

procedure TWAStreamWriter.WriteCurrency(value: Currency);

begin

//  h2n_Data8(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteDateTime(value: TDateTime);

begin

//  h2n_Data8(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteDouble(value: Double);

begin

//  h2n_Data8(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteFMTBcd(const ABcd: TBcd);

begin

  with ABcd do

  begin

    WriteByte(Precision);

    WriteByte(SignSpecialPlaces);

    WriteBuffer(Fraction, SizeOf(Fraction));

  end;

end;

 

procedure TWAStreamWriter.WriteInt64(value: Int64);

begin

//  h2n_Data8(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteLongInt(value: Integer);

begin

//  h2n_Data4(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteLongWord(value: LongWord);

begin

//  h2n_Data4(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteObjectProps(Obj: TPersistent);

  procedure WriteCollection(Coll: TCollection);

  var

    I: Integer;

  begin

    WriteObjectProps(Coll);

    WriteLongInt(Coll.Count);

    for I := 0 to Coll.Count - 1 do

      WriteObjectProps(Coll.Items[I]);

  end;

 

var

  TypData: PTypeData;

  PropCount, I, OrdVal: Integer;

  Int64Val: Int64;

  DblVal: Double;

  StrVal: string;

  ObjVal: TObject;

  WVal: WideString;

  VarVal: Variant;

  Props: PPropList;

  PropInfo: PPropInfo;

begin

  TypData := GetTypeData(Obj.ClassInfo);

  if TypData <> nil then

  begin

    PropCount := TypData.PropCount;

    if PropCount > 0 then

    begin

      GetMem(Props, PropCount * SizeOf(PPropInfo));

      try

        PropCount := GetPropList(PTypeInfo(Obj.ClassInfo), tkProperties, Props);

 

        for I := 0 to PropCount - 1 do

        begin

          PropInfo := Props^[I];

          with PropInfo^ do

          begin

            case PropType^.Kind of

              tkInteger:

                begin

                  OrdVal := GetOrdProp(Obj, PropInfo);

                  WriteLongInt(OrdVal);

//                  case GetTypeData(PropType^).OrdType of

//                    otSByte, otUByte: WriteByte(OrdVal);

//                    otSWord, otUWord: WriteWord(OrdVal);

//                    otSLong, otULong: WriteLongInt(OrdVal);

//                  end;

                end;

 

              tkInt64:

                begin

                  Int64Val := GetInt64Prop(Obj, PropInfo);

                  WriteInt64(Int64Val);

                end;

 

              tkEnumeration:

                begin

                  OrdVal := GetOrdProp(Obj, PropInfo);

                  WriteByte(OrdVal);

                end;

 

              tkFloat:

                begin

                  DblVal := GetFloatProp(Obj, PropInfo);

                  WriteDouble(DblVal);

                end;

 

              tkLString,

                tkString:

                begin

                  StrVal := GetStrProp(Obj, PropInfo);

                  WriteString(StrVal);

                end;

 

              tkWString:

                begin

                  WVal := GetWideStrProp(Obj, PropInfo);

                  WriteOleString(WVal);

                end;

 

              tkClass:

                begin

                  ObjVal := GetObjectProp(Obj, PropInfo);

                  if ObjVal is TStrings then

                    WriteString(TStrings(ObjVal).CommaText)

                  else if ObjVal is TCollection then

                    WriteCollection(TCollection(ObjVal))

                  else if ObjVal is TPersistent then

                    WriteObjectProps(TPersistent(ObjVal))

                  else

                    raise EPersistError.Create(SPersistClassError);

                end;

 

              tkSet:

                begin

                  OrdVal := GetOrdProp(Obj, PropInfo);

                  WriteLongInt(OrdVal);

                end;

 

              tkChar:

                begin

                  OrdVal := GetOrdProp(Obj, PropInfo);

                  WriteByte(OrdVal);

                end;

 

              tkWChar:

                begin

                  OrdVal := GetOrdProp(Obj, PropInfo);

                  WriteSmallInt(OrdVal);

                end;

 

              tkVariant:

                begin

                  VarVal := TypInfo.GetVariantProp(Obj, PropInfo);

                  WriteVariant(VarVal);

                end;

 

              tkDynArray:

                begin

                  TypData := GetTypeData(PropInfo.PropType^);

                  assert(TypData <> nil);

                end;

            else

              raise EPersistError.CreateFmt(SPersistTypeNotSupported,

                [GetEnumName(TypeInfo(TTypeKind), Ord(PropInfo.PropType^.Kind))]);

                {

                tkArray,

                tkRecord,

                tkMethod,

                tkInterface,

                tkDynArray

                }

            end; // case

          end; // with

        end; // for

      finally

        FreeMem(Props, PropCount * SizeOf(PPropInfo));

      end;

    end;

  end;

end;

 

procedure TWAStreamWriter.WriteOleString(value: WideString);

var

  S: string;

  len: Integer;

begin

  S := Utf8Encode(value);

  len := Length(S);

  Write7BitEncodedInt(len);

  if len > 0 then

    WriteBuffer(PChar(S)^, len);

end;

 

procedure TWAStreamWriter.WriteShortInt(value: ShortInt);

begin

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteShortString(const value: ShortString);

begin

  WriteByte(Length(value));

  WriteBuffer(value[1], Length(value));

end;

 

procedure TWAStreamWriter.WriteSingle(value: Single);

begin

//  h2n_Data4(value);

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteSmallInt(value: SmallInt);

begin

//  value := Word(h2n_Word(Word(value)));

  WriteBuffer(value, SizeOf(value));

end;

 

procedure TWAStreamWriter.WriteString(value: string);

var

  S: string;

  len: Integer;

begin

  S := AnsiToUtf8(value);

  len := Length(S);

  Write7BitEncodedInt(len);

  if len > 0 then

    WriteBuffer(PChar(S)^, len);

end;

 

procedure TWAStreamWriter.WriteTimeStamp(const ATimeStamp: TSqlTimeStamp);

begin

  with ATimeStamp do

  begin

    WriteSmallInt(Year);

    WriteWord(Month);

    WriteWord(Day);

    WriteWord(Hour);

    WriteWord(Minute);

    WriteWord(Second);

    WriteLongWord(Fractions);

  end;

end;

 

procedure TWAStreamWriter.WriteVariant(const V: Variant);

 

  procedure WriteArray(const V: Variant);

  var

    VType: Word;

    VSize, DimCount, I, ElemSize: Integer;

    LoDim, HiDim: PIntArray;

    Indices: array of Integer;

    P: Pointer;

    V2: Variant;

  begin

    VType := VarType(V) and varTypeMask;

    DimCount := VarArrayDimCount(V);

    VSize := SizeOf(Integer) * DimCount;

    GetMem(LoDim, VSize);

    GetMem(HiDim, VSize);

    try

      for I := 1 to DimCount do

      begin

        LoDim[I - 1] := VarArrayLowBound(V, I);

        HiDim[I - 1] := VarArrayHighBound(V, I);

      end;

      WriteWord(VType or varArray);

      WriteWord(DimCount);

      WriteBuffer(LoDim^, VSize);

      WriteBuffer(HiDim^, VSize);

 

      if VType in SimpleArrayTypes then

      begin

        ElemSize := VariantSize[VType];

        Assert(ElemSize <> 0);

        VSize := 1;

        for I := 0 to DimCount - 1 do

          VSize := (HiDim[I] - LoDim[I] + 1) * VSize;

        VSize := VSize * ElemSize;

        P := VarArrayLock(V);

        try

          WriteLongInt(VSize);

          WriteBuffer(P^, VSize);

        finally

          VarArrayUnlock(V);

        end;

      end

      else

      begin

        SetLength(Indices, DimCount);

 

        for I := 0 to DimCount - 1 do

          Indices[I] := LoDim[I];

 

        while True do

        begin

          V2 := VarArrayGet(V, Indices);

          WriteVariant(V2);

          Inc(Indices[DimCount - 1]);

          if Indices[DimCount - 1] > HiDim[DimCount - 1] then

            for i := DimCount - 1 downto 0 do

              if Indices[i] > HiDim[i] then

              begin

                if i = 0 then Exit;

                Inc(Indices[i - 1]);

                Indices[i] := LoDim[i];

              end;

        end;

      end;

    finally

      FreeMem(LoDim);

      FreeMem(HiDim);

    end;

  end;

 

var

  VType: Word;

  W: WideString;

begin

  VType := VarType(V);

  if (VType and varArray) <> 0 then

    WriteArray(V)

  else

    case VType and varTypeMask of

      varEmpty, varNull:

        begin

          WriteWord(VType);

        end;

      varString:

        begin

          WriteWord(VType and varTypeMask);

          WriteString(V);

        end;

      varOleStr:

        begin

          WriteWord(VType and varTypeMask);

          W := V;

          WriteOleString(W);

        end;

      varVariant:

        begin

          if VType and varByRef <> varByRef then

            raise EWriteError.CreateFmt(SInvalidVariantType, [VType]);

          WriteVariant(Variant(TVarData(V).VPointer^));

        end;

    else begin

        if VarIsFMTBcd(V) then

        begin

          WriteWord(StreamFMTBcdID);

          WriteFMTBcd(VarToBcd(V));

        end

        else if VarIsSQLTimeStamp(V) then

        begin

          WriteWord(StreamSQLTimeStampID);

          WriteTimeStamp(VarToSQLTimeStamp(V));

        end

        else begin

          WriteWord(VType and varTypeMask);

          case VType and varTypeMask of

            varSmallint: WriteSmallInt(V);

            varInteger: WriteLongInt(V);

            varSingle: WriteSingle(V);

            varDouble: WriteDouble(V);

            varCurrency: WriteCurrency(V);

            varDate: WriteDateTime(V);

            varError: WriteLongInt(V);

            varBoolean: WriteBool(V);

            varShortInt: WriteShortInt(V);

            varByte: WriteByte(V);

            varWord: WriteWord(V);

            varLongWord: WriteLongWord(V);

            varInt64: WriteInt64(V);

          else

            raise EWriteError.CreateFmt(SInvalidVariantType, [VType]);

          end;

        end;

      end;

    end;

end;

 

procedure TWAStreamWriter.WriteWord(value: Word);

begin

//  value := h2n_Word(value);

  WriteBuffer(value, SizeOf(value));

end;

 

{ TWAStreamReader }

 

function TWAStreamReader.Read7BitEncodedInt: LongInt;

var

  n: Byte;

  offset: Integer;

begin

  offset := 0;

  Result := 0;

  repeat

    n := ReadByte;

    Result := Result or ((n and $7F) shl offset);

    Inc(offset, 7);

  until (n and $80) = 0;

end;

 

function TWAStreamReader.ReadAscii(len: Byte): string;

begin

  if len > 0 then

  begin

    SetLength(Result, len);

    ReadBuffer(PChar(Result)^, len);

  end

  else

    Result := '';

end;

 

function TWAStreamReader.ReadBinary: string;

var

  Len: Integer;

begin

  Len := Read7BitEncodedInt;

  SetLength(Result, Len);

  ReadBuffer(PChar(Result)^, Len);

end;

 

function TWAStreamReader.ReadStream: Tstream;

var

  Len: Integer;

begin

  Len := Read7BitEncodedInt;

  Result := Tstream.Create;

  ReadBuffer(Result, Len);

end;

 

function TWAStreamReader.ReadBool: Boolean;

begin

  Result := (ReadByte <> 0);

end;

 

procedure TWAStreamReader.ReadBuffer(var Buffer; Count: Integer);

begin

  if (Count <> 0) and (Stream.Read(Buffer, Count) <> Count) then

    raise EReaderError.Create(SReaderError);

end;

 

function TWAStreamReader.ReadByte: Byte;

begin

  ReadBuffer(Result, 1);

end;

 

function TWAStreamReader.ReadCurrency: Currency;

begin

  ReadBuffer(Result, SizeOf(Currency));

end;

 

function TWAStreamReader.ReadDateTime: TDateTime;

begin

  ReadBuffer(Result, SizeOf(TDateTime));

end;

 

function TWAStreamReader.ReadDouble: Double;

begin

  ReadBuffer(Result, SizeOf(Double));

end;

 

procedure TWAStreamReader.ReadFMTBcd(var ABcd: TBcd);

begin

  with ABcd do

  begin

    Precision := ReadByte;

    SignSpecialPlaces := ReadByte;

    ReadBuffer(Fraction, SizeOf(Fraction));

  end;

end;

 

function TWAStreamReader.ReadInt64: Int64;

begin

  ReadBuffer(Result, SizeOf(Int64));

end;

 

function TWAStreamReader.ReadLongInt: LongInt;

begin

  ReadBuffer(Result, SizeOf(LongInt));

end;

 

function TWAStreamReader.ReadLongWord: LongWord;

begin

  ReadBuffer(Result, SizeOf(LongWord));

end;

 

procedure TWAStreamReader.ReadObjectProps(Obj: TPersistent);

  procedure ReadCollection(Coll: TCollection);

  var

    I, Len: Integer;

    Item: TCollectionItem;

  begin

    ReadObjectProps(Coll);

    Len := ReadLongInt;

    for I := 0 to Len - 1 do

    begin

      Item := Coll.Add;

      ReadObjectProps(Item);

    end;

  end;

var

  TypData: PTypeData;

  PropCount, I, OrdVal: Integer;

  Props: PPropList;

  Int64Val: Int64;

  DblVal: Double;

  StrVal: string;

  ObjVal: TObject;

  WVal: WideString;

  VarVal: Variant;

  PropInfo: PPropInfo;

begin

  TypData := GetTypeData(Obj.ClassInfo);

  if TypData <> nil then

  begin

    PropCount := TypData.PropCount;

    if PropCount > 0 then

    begin

      GetMem(Props, PropCount * SizeOf(PPropInfo));

      try

        PropCount := GetPropList(PTypeInfo(Obj.ClassInfo), tkProperties, Props);

 

        for I := 0 to PropCount - 1 do

        begin

          PropInfo := Props^[I];

          with PropInfo^ do

          begin

            case PropType^.Kind of

              tkInteger:

                begin

                  OrdVal := ReadLongInt;

                  SetOrdProp(Obj, PropInfo, OrdVal);

                end;

 

              tkInt64:

                begin

                  Int64Val := ReadInt64;

                  SetInt64Prop(Obj, PropInfo, Int64Val);

                end;

 

              tkEnumeration:

                begin

                  OrdVal := ReadByte;

                  SetOrdProp(Obj, PropInfo, OrdVal);

                end;

 

              tkFloat:

                begin

                  DblVal := ReadDouble;

                  SetFloatProp(Obj, PropInfo, DblVal);

                end;

 

              tkLString,

                tkString:

                begin

                  StrVal := ReadString;

                  SetStrProp(Obj, PropInfo, StrVal);

                end;

 

              tkWString:

                begin

                  WVal := ReadOleString;

                  SetWideStrProp(Obj, PropInfo, WVal);

                end;

 

              tkClass:

                begin

                  ObjVal := GetObjectProp(Obj, PropInfo);

                  if not (ObjVal is TPersistent) then

                    raise EPersistError.Create(SPersistClassError);

 

                  if ObjVal is TStrings then

                  begin

                    StrVal := ReadString;

                    TStrings(ObjVal).CommaText := StrVal;

                  end

                  else if ObjVal is TCollection then

                    ReadCollection(TCollection(ObjVal))

                  else

                    ReadObjectProps(TPersistent(ObjVal));

                end;

 

              tkSet:

                begin

                  OrdVal := ReadLongint;

                  SetOrdProp(Obj, PropInfo, OrdVal);

                end;

 

              tkChar:

                begin

                  OrdVal := ReadByte;

                  SetOrdProp(Obj, PropInfo, OrdVal);

                end;

 

              tkWChar:

                begin

                  OrdVal := ReadSmallInt;

                  SetOrdProp(Obj, PropInfo, OrdVal);

                end;

 

              tkVariant:

                begin

                  VarVal := ReadVariant;

                  SetVariantProp(Obj, PropInfo, VarVal);

                end;

            else

              raise EPersistError.CreateFmt(SPersistTypeNotSupported,

                [GetEnumName(TypeInfo(TTypeKind), Ord(PropInfo.PropType^.Kind))]);

            end; // case

          end; // with

        end; // for

      finally

        FreeMem(Props, PropCount * SizeOf(PPropInfo));

      end;

    end;

  end;

end;

 

function TWAStreamReader.ReadOleString: WideString;

var

  len: Integer;

  s: string;

begin

  len := Read7BitEncodedInt;

  if len > 0 then

  begin

    SetLength(s, len);

    ReadBuffer(PChar(s)^, len);

    Result := Utf8Decode(s);

  end

  else

  begin

    Result := '';

  end;

end;

 

function TWAStreamReader.ReadShortInt: ShortInt;

begin

  ReadBuffer(Result, SizeOf(ShortInt));

end;

 

function TWAStreamReader.ReadShortString: string;

var

  Len: Integer;

begin

  Result := '';

  Len := ReadByte;

  if Len = 0 then Exit;

  SetLength(Result, Len);

  ReadBuffer(PChar(Result)^, Len);

end;

 

function TWAStreamReader.ReadSingle: Single;

begin

  ReadBuffer(Result, SizeOf(Single));

end;

 

function TWAStreamReader.ReadSmallInt: SmallInt;

begin

  ReadBuffer(Result, SizeOf(SmallInt));

end;

 

function TWAStreamReader.ReadString: string;

begin

  Result := ReadOleString;

end;

 

procedure TWAStreamReader.ReadTimeStamp(var ATimeStamp: TSqlTimeStamp);

begin

  with ATimeStamp do

  begin

    Year := ReadSmallInt;

    Month := ReadWord;

    Day := ReadWord;

    Hour := ReadWord;

    Minute := ReadWord;

    Second := ReadWord;

    Fractions := ReadLongWord;

  end;

end;

 

function TWAStreamReader.ReadVariant: Variant;

 

  procedure ReadArray(VType: Word; var V: Variant);

  var

    DimCount: Word;

    VSize, I: Integer;

    LoDim, HiDim, Bounds, Indices: array of Integer;

    P: Pointer;

    V2: Variant;

  begin

    VType := VType and varTypeMask;

    DimCount := ReadWord;

    VSize := DimCount * SizeOf(Integer);

    SetLength(LoDim, DimCount);

    SetLength(HiDim, DimCount);

    SetLength(Bounds, DimCount * 2);

    ReadBuffer(LoDim[0], VSize);

    ReadBuffer(HiDim[0], VSize);

    for I := 0 to DimCount - 1 do

    begin

      Bounds[I * 2] := LoDim[I];

      Bounds[I * 2 + 1] := HiDim[I];

    end;

    V := VarArrayCreate(Bounds, VType);

 

    if VType in SimpleArrayTypes then

    begin

      VSize := ReadLongInt;

      P := VarArrayLock(V);

      try

        ReadBuffer(P^, VSize);

      finally

        VarArrayUnlock(V);

      end;

    end

    else

    begin

      SetLength(Indices, DimCount);

      for I := 0 to DimCount - 1 do

        Indices[I] := LoDim[I];

 

      while True do

      begin

        V2 := ReadVariant;

        VarArrayPut(V, V2, Indices);

        Inc(Indices[DimCount - 1]);

        if Indices[DimCount - 1] > HiDim[DimCount - 1] then

          for i := DimCount - 1 downto 0 do

            if Indices[i] > HiDim[i] then

            begin

              if i = 0 then Exit;

              Inc(Indices[i - 1]);

              Indices[i] := LoDim[i];

            end;

      end;

    end;

  end;

 

var

  VType: Word;

  ABcd: TBcd;

  ATimeStamp: TSQLTimeStamp;

begin

  VType := ReadWord;

  if VType and varArray <> 0 then

    ReadArray(VType, Result)

  else

    case VType of

      varEmpty: VarClear(Result);

      varNull: Result := Null;

      varString: Result := ReadString;

      varOleStr: Result := ReadOleString;

      varVariant: Result := ReadVariant;

      varSmallint: Result := ReadSmallint;

      varInteger: Result := ReadLongInt;

      varSingle: Result := ReadSingle;

      varDouble: Result := ReadDouble;

      varCurrency: Result := ReadCurrency;

      varDate: Result := ReadDateTime;

      varError:

        begin

          Result := ReadLongInt;

          TVarData(Result).VType := varError;

        end;

      varBoolean: Result := ReadBool;

      varShortInt: Result := ReadShortInt;

      varByte: Result := ReadByte;

      varWord: Result := ReadWord;

      varLongWord: Result := ReadLongWord;

      varInt64: Result := ReadInt64;

    else

      if VType = StreamFMTBcdID then

      begin

        Self.ReadFMTBcd(ABcd);

        Result := VarFMTBcdCreate(ABcd);

      end

      else if VType = StreamSQLTimeStampID then

      begin

        ReadTimeStamp(ATimeStamp);

        Result := VarSQLTimeStampCreate(ATimeStamp);

      end

      else

        raise EReadError.CreateFmt(SInvalidVariantType, [VType]);

    end;

end;

 

function TWAStreamReader.ReadWord: Word;

begin

  ReadBuffer(Result, SizeOf(Word));

end;

 

//下列2个过程由Dcopyboy编写

function AdoQuerySaveTostream(Adoq: Tadoquery): TMemoryStream;

var

  aa: TWAStreamWriter;

  i, b: integer;

  Stream: TMemoryStream;

begin

  aa := TWAStreamWriter.Create;

  aa.Stream := TMemoryStream.Create;

  aa.WriteString(Adoq.SQL.Text);

  b := Adoq.Parameters.Count;

  aa.WriteSmallInt(b);

  for i := 0 to b - 1 do begin

    aa.WriteString(adoq.Parameters[i].Name);

    if adoq.Parameters[i].DataType = ftGraphic then begin

      aa.WriteByte(250);

      aa.WriteVariant(adoq.Parameters[i].Value);

    end

    else if adoq.Parameters[i].DataType = ftMemo then begin

      aa.WriteByte(249);

      aa.WriteVariant(adoq.Parameters[i].Value);

    end

    else if adoq.Parameters[i].DataType = ftFmtMemo then begin

      aa.WriteByte(248);

      aa.WriteVariant(adoq.Parameters[i].Value);

    end

    else if adoq.Parameters[i].DataType = ftblob then begin

      aa.WriteByte(247);

      aa.WriteVariant(adoq.Parameters[i].Value);

    end

    else begin

      aa.WriteByte(1);

      aa.WriteVariant(adoq.Parameters[i].Value);

    end;

  end;

  Result := TMemoryStream(aa.Stream);

  aa.Free;

end;

 

function AdoQueryLoadFromstream(Adoq: Tadoquery; Stream: TMemoryStream): boolean;

var

  aa: TWAStreamReader;

  i, b: integer;

  Stream1: TMemoryStream;

  PName: string;

  Ptype: word;

  MyValue: Variant;

begin

  aa := TWAStreamReader.Create;

  aa.Stream := TMemoryStream.Create;

  Stream.Position := 0;

  TMemoryStream(aa.Stream).LoadFromStream(stream);

  Adoq.Close;

  aa.Stream.Position := 0;

  adoq.SQL.Text := aa.ReadString;

  b := aa.ReadSmallInt;

  for i := 0 to b - 1 do begin

    PName := aa.ReadString;

    Ptype := aa.ReadByte;

    if ptype = 250 then begin

      adoq.Parameters.ParamByName(Pname).DataType := ftGraphic;

      adoq.Parameters.ParamByName(Pname).Value := aa.ReadVariant;

      adoq.Parameters.ParamByName(Pname).DataType := ftGraphic;

    end

    else if ptype = 249 then begin

      adoq.Parameters.ParamByName(Pname).DataType := ftMemo;

      adoq.Parameters.ParamByName(Pname).Value := aa.ReadVariant;

      adoq.Parameters.ParamByName(Pname).DataType := ftMemo;

    end

    else if ptype = 248 then begin

      adoq.Parameters.ParamByName(Pname).DataType := ftFmtMemo;

      adoq.Parameters.ParamByName(Pname).Value := aa.ReadVariant;

      adoq.Parameters.ParamByName(Pname).DataType := ftFmtMemo;

    end

    else if ptype = 247 then begin

      adoq.Parameters.ParamByName(Pname).DataType := ftblob;

      adoq.Parameters.ParamByName(Pname).Value := aa.ReadVariant;

      adoq.Parameters.ParamByName(Pname).DataType := ftblob;

    end

    else begin

      adoq.Parameters.ParamByName(Pname).Value := aa.ReadVariant;

    end;

  end;

  aa.Free;

  Result := true;

end;

 

end.

 

unit Unit1;

 

interface

 

uses

  Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls, Forms,

  Dialogs, StdCtrls, WebAdoStream, DB, ADODB, ExtCtrls, ComCtrls, jpeg;

 

type

  TForm1 = class(TForm)

    Button1: TButton;

    ADOConnection1: TADOConnection;

    ADOQuery1: TADOQuery;

    RichEdit1: TRichEdit;

    Image1: TImage;

    Button2: TButton;

    Button3: TButton;

    Button4: TButton;

    Button5: TButton;

    procedure Button1Click(Sender: TObject);

    procedure Button2Click(Sender: TObject);

    procedure Button3Click(Sender: TObject);

    procedure Button4Click(Sender: TObject);

    procedure Button5Click(Sender: TObject);

  private

    { Private declarations }

  public

    { Public declarations }

  end;

 

var

  Form1: TForm1;

 

implementation

 

{$R *.dfm}

 

{

//测试用表：

CREATE TABLE [dbo].[test] (

 [f1] [float] NULL ,

 [f2] [int] NULL ,

 [f3] [money] NULL ,

 [f4] [numeric](18, 0) NULL ,

 [f5] [real] NULL ,

 [d1] [datetime] NULL ,

 [c1] [char] (10) NULL ,

 [c2] [varchar] (50) NULL ,

 [b1] [ntext] NULL ,

 [b2] [text] NULL ,

 [b3] [image] NULL ,

 [B4] [image] NULL ,

 [id] [int] IDENTITY (1, 1) NOT NULL

) ON [PRIMARY] TEXTIMAGE_ON [PRIMARY]

}

 

procedure TForm1.Button1Click(Sender: TObject);

var

  Stream1: TMemoryStream;

begin

  ADOQuery1.Close;

  ADOQuery1.SQL.Text := 'Insert into test ( f1,f2,f3,f4,f5,d1,c1,c2,b1,b2,b3,b4) ' +

    ' values ( :f1,:f2,:f3,:f4,:f5,:d1,:c1,:c2,:b1,:b2,:b3,:b4) ';

  ADOQuery1.Parameters.ParamByName('f1').Value := 10;

  ADOQuery1.Parameters.ParamByName('f2').Value := 20;

  ADOQuery1.Parameters.ParamByName('f3').Value := 30;

  ADOQuery1.Parameters.ParamByName('f4').Value := 40;

  ADOQuery1.Parameters.ParamByName('f5').Value := 50;

  ADOQuery1.Parameters.ParamByName('d1').Value := now();

  ADOQuery1.Parameters.ParamByName('c1').Value := '字段1';

  ADOQuery1.Parameters.ParamByName('c2').Value := '字段2';

  ADOQuery1.Parameters.ParamByName('b1').LoadFromFile('本草纲目.txt', ftMemo);

  ADOQuery1.Parameters.ParamByName('b2').LoadFromFile('本草纲目.txt', ftMemo);

  ADOQuery1.Parameters.ParamByName('b3').LoadFromFile('东阳.jpg', ftblob);

  ADOQuery1.Parameters.ParamByName('b4').LoadFromFile('东阳.jpg', ftGraphic);

  Stream1 := TMemoryStream.Create;

  Stream1.LoadFromStream(AdoQuerySaveTostream(ADOQuery1));

  stream1.SaveToFile('c:/parastreamtest');

  Stream1.Free;

  Stream1 := TMemoryStream.Create;

  stream1.LoadFromFile('c:/parastreamtest');

  ADOQuery1.Close;

  ADOQuery1.sql.clear;

  AdoQueryLoadFromstream(ADOQuery1, Stream1);

  ADOQuery1.ExecSQL;

  Stream1.Free;

end;

 

procedure TForm1.Button2Click(Sender: TObject);

var

  Stream1: TMemoryStream;

begin

  RichEdit1.Lines.Clear;

  ADOQuery1.Close;

  ADOQuery1.SQL.Text := 'select b1 from test ';

  ADOQuery1.open;

  Stream1 := TMemoryStream.Create;

  Tmemofield(ADOQuery1.FieldByName('b1')).SaveToStream(stream1);

  stream1.Position := 0;

  RichEdit1.Lines.LoadFromStream(stream1);

  stream1.free;

end;

 

procedure TForm1.Button3Click(Sender: TObject);

var

  Stream1: TMemoryStream;

begin

  RichEdit1.Lines.Clear;

  ADOQuery1.Close;

  ADOQuery1.SQL.Text := 'select b2 from test ';

  ADOQuery1.open;

  Stream1 := TMemoryStream.Create;

  Tmemofield(ADOQuery1.FieldByName('b2')).SaveToStream(stream1);

  stream1.Position := 0;

  RichEdit1.Lines.LoadFromStream(stream1);

  stream1.free;

 

end;

 

procedure TForm1.Button4Click(Sender: TObject);

var

  Stream1: TMemoryStream;

  Jpeg1: TJPEGImage;

begin

  ADOQuery1.Close;

  ADOQuery1.SQL.Text := 'select b3 from test ';

  ADOQuery1.open;

  Stream1 := TMemoryStream.Create;

  Tblobfield(ADOQuery1.FieldByName('b3')).SaveToStream(stream1);

  stream1.Position := 0;

  Jpeg1 := TJPEGImage.Create;

  Jpeg1.LoadFromStream(stream1);

  stream1.free;

  Image1.Picture.Assign(jpeg1);

  jpeg1.Free;

end;

 

procedure TForm1.Button5Click(Sender: TObject);

var

  Stream1: TMemoryStream;

  Jpeg1: TJPEGImage;

begin

  ADOQuery1.Close;

  ADOQuery1.SQL.Text := 'select b4 from test ';

  ADOQuery1.open;

  Stream1 := TMemoryStream.Create;

  Tblobfield(ADOQuery1.FieldByName('b4')).SaveToStream(stream1);

  stream1.Position := 0;

  Jpeg1 := TJPEGImage.Create;

  Jpeg1.LoadFromStream(stream1);

  stream1.free;

  Image1.Picture.Assign(jpeg1);

  jpeg1.Free;

 

end;

 

end.