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.