Более-менее корректный способ передачи произвольных данных в функцию Format(),
которая, как известно, принимает array of const
(Но это можно исправить)
program project1;
{$APPTYPE CONSOLE}
uses
Classes, SysUtils, Variants;
type
TConstArray = array of TVarRec;
// Copies a TVarRec and its contents. If the content is referenced
// the value will be copied to a new location and the reference
// updated.
function CopyVarRec(const Item: TVarRec): TVarRec;
var
W: WideString;
begin
// Copy entire TVarRec first
Result := Item;
// Now handle special cases
case Item.VType of
vtExtended:
begin
New(Result.VExtended);
Result.VExtended^ := Item.VExtended^;
end;
vtString:
begin
// Improvement suggestion by Hallvard Vassbotn: only copy real length.
GetMem(Result.VString, Length(Item.VString^) + 1);
Result.VString^ := Item.VString^;
end;
vtPChar:
Result.VPChar := StrNew(Item.VPChar);
// There is no StrNew for PWideChar
vtPWideChar:
begin
W := Item.VPWideChar;
GetMem(Result.VPWideChar,
(Length(W) + 1) * SizeOf(WideChar));
Move(PWideChar(W)^, Result.VPWideChar^,
(Length(W) + 1) * SizeOf(WideChar));
end;
// A little trickier: casting to AnsiString will ensure
// reference counting is done properly.
vtAnsiString:
begin
// nil out first, so no attempt to decrement reference count.
Result.VAnsiString := nil;
AnsiString(Result.VAnsiString) := AnsiString(Item.VAnsiString);
end;
vtCurrency:
begin
New(Result.VCurrency);
Result.VCurrency^ := Item.VCurrency^;
end;
vtVariant:
begin
New(Result.VVariant);
Result.VVariant^ := Item.VVariant^;
end;
// Casting ensures proper reference counting.
vtInterface:
begin
Result.VInterface := nil;
IInterface(Result.VInterface) := IInterface(Item.VInterface);
end;
// Casting ensures a proper copy is created.
vtWideString:
begin
Result.VWideString := nil;
WideString(Result.VWideString) := WideString(Item.VWideString);
end;
vtInt64:
begin
New(Result.VInt64);
Result.VInt64^ := Item.VInt64^;
end;
vtUnicodeString:
begin
// Similar to AnsiString.
Result.VUnicodeString := nil;
UnicodeString(Result.VUnicodeString) := UnicodeString(Item.VUnicodeString);
end;
// VPointer and VObject don't have proper copy semantics so it
// is impossible to write generic code that copies the contents
end;
end;
function CreateConstArray(const Elements: array of const): TConstArray;
var
I: Integer;
begin
SetLength(Result, Length(Elements));
for I := Low(Elements) to High(Elements) do
Result[I] := CopyVarRec(Elements[I]);
end;
function CreateConstArray(L:TStringList): TConstArray;
var
I: Integer;
s: string;
V: TVarRec;
begin
SetLength(Result, L.Count);
for I := 0 to L.Count-1 do
begin
s:=L.Strings[i];
V.VType := vtAnsiString;
V.VAnsiString := pointer(s);
Result[I] := CopyVarRec(V);
end;
end;
// use this function on copied TVarRecs only!
procedure FinalizeVarRec(var Item: TVarRec);
begin
case Item.VType of
vtExtended:
Dispose(Item.VExtended);
vtString:
Dispose(Item.VString);
vtPChar:
StrDispose(Item.VPChar);
vtPWideChar:
FreeMem(Item.VPWideChar);
vtAnsiString:
AnsiString(Item.VAnsiString) := '';
vtCurrency:
Dispose(Item.VCurrency);
vtVariant:
Dispose(Item.VVariant);
vtInterface:
IInterface(Item.VInterface) := nil;
vtWideString:
WideString(Item.VWideString) := '';
vtInt64:
Dispose(Item.VInt64);
vtUnicodeString:
UnicodeString(Item.VUnicodeString) := '';
end;
Item.VInteger := 0;
end;
// A TConstArray contains TVarRecs that must be finalized. This function
// does that for all items in the array.
procedure FinalizeConstArray(var Arr: TConstArray);
var
I: Integer;
begin
for I := Low(Arr) to High(Arr) do
FinalizeVarRec(Arr[I]);
Arr := nil;
end;
var
ConstArray: TConstArray;
LArray: TConstArray;
L:TStringList;
begin
L:=TStringList.Create;
L.Add('5.5');
L.Add('BCA');
ConstArray := CreateConstArray([1, 'Hello', 7.9, IntToStr(1234)]);
LArray:=CreateConstArray(L);
try
WriteLn('TEST1 '+ Format('%s / %s', LArray));
WriteLn('TEST2 '+ Format('%d --- %s --- %0.2f --- %s', ConstArray));
Writeln('TEST3 '+ Format('%s --- %0.2f', Copy(ConstArray, 1, 2)));
finally
FinalizeConstArray(ConstArray);
FinalizeConstArray(LArray);
end;
ReadLn;
L.Free;
end.
Недостаток данного кода заключается в том, что '5.5' - это не число,
а строка, и форматируется по правилам строки, т.е.
выровнять нули так не получится.
Free Pascal Справочник v0.05 © 2007-2025 Igor Salnikov aka SunDoctor