I'm trying to migrate some xml code from the default delphi XML routines to NativeXML, hopefully to improve the speed (a lot).
The XML files are of the form:
<Datafile>
<Header>
<Name>'My Name'</Name>
<Address>'My Address'</Address>
</Header>
<Body>
<ValuesSets>
<ValuesSet>
<v>1</v>
<v>2</v>
<v>3</v>
<v>4</v>
</ValuesSet>
<ValuesSet>
<v>5</v>
<v>6</v>
<v>7</v>
<v>8</v>
</ValuesSet>
</ValuesSets>
</Body>
</Datafile>
My problem is how to iterate through each of the sets of values. A more or less direct translation of the old code didn't work:
procedure TForm1.Button1Click(Sender: TObject);
var
AXMLDoc : TNativeXML ;
FileID : TFilename ;
I : Integer ;
J : Integer ;
HeaderNode : TXMLNode ;
BodyNode : TXMLNode ;
ValuesSetsNode : TXMLNode ;
ValuesSetNode : TXMLNode ;
Values : array of array of integer ;
begin
try
Memo1.Lines.Clear ;
FileID := 'Sample.XML' ;
Memo1.Lines.LoadFromFile (FileID) ;
AXMLDoc := TNativeXml.Create (nil) ;
AXMLDoc.LoadFromFile (FileID) ;
if Assigned(AXMLDoc.Root) then
begin
HeaderNode := AXMLDoc.Root.NodeByName ('Header') ;
if Assigned (HeaderNode) then
begin
// < process header items >
BodyNode := AXMLDoc .Root.NodeByName ('Body') ;
if Assigned (BodyNode) then
begin
ValuesSetsNode := BodyNode.NodeByName ('ValuesSets') ;
if Assigned (ValuesSetsNode) then
begin
SetLength (Values, ValuesSetsNode.NodeCount) ;
for i := 0 to ValuesSetsNode.NodeCount - 1 do
begin
ValuesSetNode := ValuesSetsNode [i] ;
if Assigned (ValuesSetNode) then
begin
SetLength (Values [i], ValuesSetNode.NodeCount) ;
for j := 0 to ValuesSetNode.NodeCount - 1 do
begin
Values [i, j] := StrToIntDef (ValuesSetNode [j].Value, 0) ;
end ;
end ;
end ;
end ;
end ;
end ;
end ;
for i := 0 to Length (Values) - 1 do
begin
for j := 0 to Length (Values [i]) - 1 do
begin
Memo1.Lines.Add (Format ('Values [%d, %d] = %d', [i, j, Values [i, j]])) ;
end ;
end ;
finally
FreeAndNil (AXMLDoc) ;
end ;
end ;
The output I get is:
Values [1, 0] = 0
Values [1, 1] = 1
Values [1, 2] = 0
Values [1, 3] = 2
Values [1, 4] = 0
Values [1, 5] = 3
Values [1, 6] = 0
Values [1, 7] = 4
Values [1, 8] = 0
Values [3, 0] = 0
Values [3, 1] = 5
Values [3, 2] = 0
Values [3, 3] = 6
Values [3, 4] = 0
Values [3, 5] = 7
Values [3, 6] = 0
Values [3, 7] = 8
Values [3, 8] = 0
and I was expecting:
Values [0, 0] = 1
Values [0, 1] = 2
Values [0, 2] = 3
Values [0, 3] = 4
Values [1, 0] = 5
Values [1, 1] = 6
Values [1, 2] = 7
Values [1, 3] = 8
so it seems as if the Nodes property of TNativeXML is not exactly the same as IXMLNode's ChildNodes property.
How do I iterate all the child nodes within a parent node? I don't want to give each one a unique name (<v1001>1234</v1001>, <v1002>4321</v1002>... etc), as I only ever need to access them sequentially, and don't want the speed penalty (or increased file size) of having to do a NodeByName for every value (there can be many of these values).
UPDATE **
NativeXML does have an equivalent to ChildNodes - it's called Containers (not ChildContainers as the online documentation would have you believe). The following worked:
var
AXMLDoc : TNativeXML ;
FileID : TFilename ;
I : Integer ;
J : Integer ;
HeaderNode : TXMLNode ;
BodyNode : TXMLNode ;
ValuesSetsNode : TXMLNode ;
ValuesSetNode : TXMLNode ;
Values : array of array of integer ;
begin
try
Memo1.Lines.Clear ;
FileID := 'Sample.XML' ;
Memo1.Lines.LoadFromFile (FileID) ;
AXMLDoc := TNativeXml.Create (nil) ;
AXMLDoc.LoadFromFile (FileID) ;
if Assigned(AXMLDoc.Root) then
begin
HeaderNode := AXMLDoc.Root.NodeByName ('Header') ;
if Assigned (HeaderNode) then
begin
// < process header items >
BodyNode := AXMLDoc .Root.NodeByName ('Body') ;
if Assigned (BodyNode) then
begin
ValuesSetsNode := BodyNode.NodeByName ('ValuesSets') ;
if Assigned (ValuesSetsNode) then
begin
SetLength (Values, ValuesSetsNode.ContainerCount) ;
for i := 0 to ValuesSetsNode.ContainerCount - 1 do
begin
ValuesSetNode := ValuesSetsNode.Containers [i] ;
if Assigned (ValuesSetNode) then
begin
SetLength (Values [i], ValuesSetNode.ContainerCount) ;
for j := 0 to ValuesSetNode.ContainerCount - 1 do
begin
Values [i, j] := StrToIntDef (ValuesSetNode.Containers [j].Value, 0) ;
end ;
end ;
end ;
end ;
end ;
end ;
end ;
for i := 0 to Length (Values) - 1 do
begin
for j := 0 to Length (Values [i]) - 1 do
begin
Memo1.Lines.Add (Format ('Values [%d, %d] = %d', [i, j, Values [i, j]])) ;
end ;
end ;
finally
FreeAndNil (AXMLDoc) ;
end ;
end ;
It's actually pretty slow - to read 32k float values takes many 10's of seconds.
OP :
so it seems as if the Nodes property of TNativeXML is not exactly the
same as IXMLNode's ChildNodes property.
You are right . There must be something more to be done to achieve this result.
procedure TForm1.Button1Click(Sender: TObject);
var
[...]
i , i2 : Integer ;
j , j2 : Integer ;
[...]
begin
try
Memo1.Lines.Clear ;
[...]
BodyNode := AXMLDoc .Root.NodeByName ('Body') ;
if Assigned (BodyNode) then
begin
ValuesSetsNode := BodyNode.NodeByName ('ValuesSets') ;
if Assigned (ValuesSetsNode) then
begin
SetLength (Values, ValuesSetsNode.NodeCount) ;
ValuesSetNode := ValuesSetsNode.NodeByName('ValuesSet') ;
if Assigned (ValuesSetNode) then
begin
i2:=0;
for i := 0 to ValuesSetSNode.NodeCount - 1 do begin
if i > 0 then ValuesSetNode := ValuesSetsNode.NextSibling(ValuesSetNode) ;
if ValuesSetNode=nil then break;
if ValuesSetNode.NodeCount > 0 then begin
SetLength(Values[i2], ValuesSetNode.NodeCount) ;
j2:=0;
for j := 0 to ValuesSetNode.NodeCount - 1 do begin
if pos(#13,ValuesSetNode[j].Value) > 0 then continue;
Values [i2, j2] := StrToIntDef (ValuesSetNode[j].Value, 0) ;
inc(j2);
end ; // for j
SetLength(Values[i2],j2);
inc(i2);
end;
end ; // for i
end; // ValuesSetNode
end; // ValuesSetsNode
end; // BodyNode
end; // HeaderNode
end; // AXMLDoc.Root
[...]
finally
FreeAndNil (AXMLDoc) ;
end ;
end ;
Delphi 5 / Delphi XE2 NativeXml 4.07
Related
I have a simple table in database with several fields
ID,A1,A2,A3,A4,A5,B1,B2,B3,B4,B5 : Integer and R : Float
i usually use this function with several parameters to get a total on R
function Total(const X : array of NUMBER): Float;
begin
QUERY.SQL.Add('Select Sum(R) as Total from Table where
' ( CASE WHEN :P1 = 0 THEN A1 = A1 ELSE A1 = :Y1 END ) '+
'and ( CASE WHEN :P2 = 0 THEN A2 = A2 ELSE A2 = :Y2 END ) '+
'and ( CASE WHEN :P3 = 0 THEN A3 = A3 ELSE A3 = :Y3 END ) '+
'and ( CASE WHEN :P4 = 0 THEN A4 = A4 ELSE A4 = :Y4 END ) '+
'and ( CASE WHEN :P5 = 0 THEN A5 = A5 ELSE A5 = :Y5 END ) '+
'and ( CASE WHEN :P6 = 0 THEN B1 = B1 ELSE B1 = :Y6 END ) '+
'and ( CASE WHEN :P7 = 0 THEN B2 = B2 ELSE B2 = :Y7 END ) '+
'and ( CASE WHEN :P8 = 0 THEN B3 = B3 ELSE B3 = :Y8 END ) '+
'and ( CASE WHEN :P9 = 0 THEN B4 = B4 ELSE B4 = :Y9 END ) '+
'and ( CASE WHEN :P10 = 0 THEN B5 = B5 ELSE B5 = :Y10 END ) ');
if X[1] = 0 then QUERY.ParamByName('P1').Value := 0 ;
if X[2] = 0 then QUERY.ParamByName('P2').Value := 0 ;
if X[3] = 0 then QUERY.ParamByName('P3').Value := 0 ;
if X[4] = 0 then QUERY.ParamByName('P4').Value := 0 ;
if X[5] = 0 then QUERY.ParamByName('P5').Value := 0 ;
if X[6] = 0 then QUERY.ParamByName('P6').Value := 0 ;
if X[7] = 0 then QUERY.ParamByName('P7').Value := 0 ;
if X[8] = 0 then QUERY.ParamByName('P8').Value := 0 ;
if X[9] = 0 then QUERY.ParamByName('P9').Value := 0 ;
if X[10] = 0 then QUERY.ParamByName('P10').Value := 0 ;
QUERY.ParamByName('Y1').Value := X[0];
QUERY.ParamByName('Y2').Value := X[1];
QUERY.ParamByName('Y3').Value := X[2];
QUERY.ParamByName('Y4').Value := X[3];
QUERY.ParamByName('Y5').Value := X[4];
QUERY.ParamByName('Y6').Value := X[5];
QUERY.ParamByName('Y7').Value := X[6];
QUERY.ParamByName('Y8').Value := X[7];
QUERY.ParamByName('Y9').Value := X[8];
QUERY.ParamByName('Y10').Value := X[9];
QUERY.Open ;
Result := QUERY.FieldByName('Total').Value ;
end;
for example a have a
0,0,0,0,2,3,1,2,3,4,1.00
1,0,0,1,2,3,1,2,3,4,2.00
1,0,0,1,2,3,1,2,3,4,3.00
0,0,0,1,2,3,1,2,3,4,4.00
When a use Total(0,0,0,0,0,0,0,0,0,0) function return a 10.
When a use Total(1,0,0,0,0,0,0,0,0,0) function return a 5.
When a use Total(1,0,0,1,0,0,0,0,0,0) function return a 1. and so on
I Have a record with the same fields
and a array of records
T_Rec: array of T_Record;
I need to hava a function to do the same as function Total
function Total1(const X : array of NUMBER): Float;
var R : Real ;
begin
R := 0 ;
for i := 0 to Length(T_Rec)-1 do
begin
How to do this SQL Hack
CASE WHEN :P1 = 0 THEN A1 = A1 ELSE A1 = :Y1 END
in condisions ?
......
R := R + T_Rec.R
end;
Any Help be appreciate.
Thanks.
Float is unknown to Delphi use Real instead.
NUMBER is unknown to Delphi use Integer instead.
When you want to change your query string don't use parameter, Parameters slow down your query. Parameters useful when you set query string and change only parameters value.
Why you add (A1 = A1) to your condition, it's useless and slow down your query.
My prefer function is like this:
function Total(const X : array of Integer): Real;
const
FieldNames : array [0..9] of String = ('A1', 'A2', 'A3', 'A4', 'A5', 'B1', 'B2', 'B3', 'B4', 'B5');
var
s : String;
i : integer;
begin
//condition section
s := '';
for i := 0 to 9 do
if (X[i] <> 0) then s := s + ' AND (' + FieldNames[i] + ' = ' + IntToStr(X[i]) + ')';
if (s <> '') then
begin
System.Delete(s, 1, 4); //remove first AND
s := ' WHERE' + s;
end;
// query section
QUERY.SQL.Add('Select Sum(R) as Total from Table' + s);
QUERY.Open;
Result := QUERY.FieldByName('Total').Value;
end;
Now let's define T_Record something Like this :
type
T_Record = record
A1, A2, A3, A4, A5, B1, B2, B3, B4, B5 : Integer;
R : Real;
end;
You can search in T_Rec: array of T_Record with this function :
function Total1(const X : array of Integer): Real;
var
R : Real;
i : Integer;
TRecord : T_Record;
begin
R := 0 ;
for TRecord in T_Rec do
begin
if (((X[0] = 0) or (TRecord.A1 = X[0])) and
((X[1] = 0) or (TRecord.A2 = X[1])) and
((X[2] = 0) or (TRecord.A3 = X[2])) and
((X[3] = 0) or (TRecord.A4 = X[3])) and
((X[4] = 0) or (TRecord.A5 = X[4])) and
((X[5] = 0) or (TRecord.B1 = X[5])) and
((X[6] = 0) or (TRecord.B2 = X[6])) and
((X[7] = 0) or (TRecord.B3 = X[7])) and
((X[8] = 0) or (TRecord.B4 = X[8])) and
((X[9] = 0) or (TRecord.B5 = X[9]))) then
R := R + TRecord.R;
end;
Result := R;
end;
Good luck 😄
I have a n number of strings which I need to merge into n number of strings in multiple combinations/permutations. the string cannot repeat itself and combination in single merge doesnt matter ( S1, S2 ) = ( S2, S1 )...
This is used when building a tree model and it decided which combination of characteristics is the best to merge...
This code is what I've wrote for permutations. List contains characteristic attributes, Splits is the number of splits I want to make , SplitList return which attributes need to be merge together... for binary tree I input "2" for Splits and for non-binary tree I run a cycle to return the best value for each of the splits .
I.E.
I have "A", "B", "C", "D", "E", "F".
If i Need to merge into 2 string
2. "A,B,C" and "D,E,F" or "A,C,E" and "B,D,F" or "A,E,F" and "B,C,D"
3. "A,B, and "C,D" and "E,F" or "A,D" and "C,B" and "E,F"
Also minimum number in a string is 1, maximum n-1.
I.E
2. "A" and "B,C,D,E,F" or "C" and "A,B,D,E,F" is a valid merging
function TSplitEngine.doTest(List: TList; Splits: Integer; var SplitList : TArray<Integer>): Double;
var
i, j, SplitNo, Pointer : Integer;
tmpNode : TDTreeNode;
CurRes, CurOut : Double;
TestArr : RTestArr;
ResArr: TArray<double>;
SplitStr : String;
DoSplit, FindSplit : Boolean;
TestList : TArray<Integer>;
begin
Result := DefaultVal;
SetLength( TestList, Splits );
for i := 0 to Length( TestList ) - 1 do
TestList[ i ] := i + 1;
TestArr.Size := Splits + 1;
DoSplit := True;
while DoSplit do
begin
Inc(Iteration);
TestArr.Clear;
for i := 0 to List.Count - 1 do
begin
tmpNode := TDTreeNode( List[ i ] );
j := 0;
FindSplit := True;
While ( j < Length( TestList ) ) and ( FindSplit ) do
begin
if i < TestList[ j ] then
begin
Combine Characteristics
FindSplit := False;
end
else if ( i >= TestList[ Length( TestList ) - 1 ] ) then
begin
Combine last split characteristics
FindSplit := False;
end;
inc( j );
end;
TestArr.AllTotal := TestArr.AllTotal + ( tmpNode.Goods + tmpNode.Bads );
end;
//CalcNode returns the result of this particular splits
CurRes := CalcNode( TestArr );
SetLength( ResArr, 2 );
ResArr[ 1 ] := CurRes;
if IsBetter( CurRes, Result ) then
begin
Result := CurRes;
SplitList := Copy( TestList, 0, Length( TestList ) );
end;
SplitNo := 1;
FindSplit := True;
//Move the split like a pointer...
i := Length( TestList ) - 1;
while ( i >= 0 ) and FindSplit do
begin
if ( TestList[ i ] < ( List.Count - SplitNo ) ) then
begin
Pointer := TestList[ i ] + 1;
for j := i to Length( TestList ) - 1 do
begin
TestList[ j ] := Pointer;
inc( Pointer );
end;
FindSplit := False;
end
else if ( i = 0 ) then
DoSplit := False;
inc ( SplitNo );
Dec( i );
end;
end;
end;
the permutation code seems to be working and the only thing to do would be to tidy it up.
I've tried a few times to convert this code to do combinations but never seemed to work.
I have old code for generation of set partitions with set size <= 10 (due to set comparison implemented through strings). Note that number of partitions for n=10 is 115975 (Bell number).
Procedure generates non-repeating partitions of set into KP parts, so you have to go through all KP values.
Part of output including some two-parts and some three-parts partitions:
1,4 | 2,3,5 |
1,4,5 | 2,3 |
1,5 | 2,3,4 |
1 | 2 | 3,4,5 |
1 | 2,3 | 4,5 |
1 | 2,3,4 | 5 |
procedure generate_multi_partitions(values: array of Integer; KP: Integer);
var
n, i: Integer;
avail: array of Boolean;
output: array of TStringList;
procedure foo(k: Integer); forward;
procedure bar(k, i: Integer);
var
j: Integer;
begin
output[k].add(IntToStr(values[i]));
avail[i] := False;
foo(k + 1);
for j := i + 1 to n - 1 do
if avail[j] and ((j = 0) or (values[j - 1] <> values[j]) or
(not avail[j - 1])) then
bar(k, j);
output[k].Delete(output[k].Count - 1);
avail[i] := True;
end;
procedure foo(k: Integer);
var
i, j: Integer;
s: string;
begin
if (k >= 2) and (output[k - 2].CommaText > output[k - 1].CommaText) then
Exit;
if k = KP - 1 then begin
output[k].Clear;
for i := 0 to n - 1 do
if avail[i] then
output[k].add(IntToStr(values[i]));
if (output[k].Count > 0) and
((k = 0) or (output[k - 1].CommaText <= output[k].CommaText)) then
begin
s := '';
for j := 0 to KP - 1 do
s := s + output[j].CommaText + ' | ';
Memo1.Lines.add(s);
end;
output[k].Clear;
end
else
for i := 0 to n - 1 do
if avail[i] then begin
bar(k, i);
Exit;
end;
end;
begin
n := length(values);
SetLength(avail, n);
SetLength(output, KP);
for i := 0 to KP - 1 do
output[i] := TStringList.Create;
for i := 0 to n - 1 do
avail[i] := True;
foo(0);
for i := 0 to KP - 1 do
output[i].Free;
end;
var
parts: Integer;
begin
for parts := 1 to 5 do
generate_multi_partitions([1, 2, 3, 4, 5], parts);
end;
Have some old code (written by someone else) that I need to fix to work with Unicode strings in Delphi 10.1. EDIT: I've narrowed my question down to the following: code below fails with unicode strings. Suggestions?
//global variable:
var
UpCaseLookup : array[ 1..255 ] of char;
// ---- Knuth, Morris, Pratt:
type
failure = array[1..255] of word;
procedure PrepareUpcaseLookup;
var
S : string; //was shortstring;
i : integer;
begin
for i := 1 to 255 do
begin
S := ToUpper( chr(i) ); //was AnsiUpperCase
UpCaseLookup[i] := S[1]
end
end;
function PosKnuthMorrisPratt(Pattern, Text: string): Integer;
var
Prefix: array of Integer;
i, k: Integer;
begin
Result := 0;
if (Pattern = '') or (Text = '') then
Exit;
Pattern := UpperCase(Pattern); // case-insensitive
Text := UpperCase(Text);
// Buld prefix function array
SetLength(Prefix, Length(Pattern) + 1);
Prefix[1] := 0;
k := 0;
for i := 2 to Length(Pattern) do begin
while (k > 0) and (Pattern[k + 1] <> Pattern[i]) do
k := Prefix[k];
if Pattern[k + 1] = Pattern[i] then
Inc(k);
Prefix[i] := k;
end;
k := 0;
for i := 1 to Length(Text) do begin
while (k > 0) and (Pattern[k + 1] <> Text[i]) do
k := Prefix[k];
if Pattern[k + 1] = Text[i] then
Inc(k);
if k = Length(Pattern) then
Exit(i + 1 - Length(Pattern));
end;
end;
begin
Memo1.Lines.Add(IntToStr(PosKnuthMorrisPratt('abaBc', 'ggabagabAbccsab')));
Memo1.Lines.Add(IntToStr(PosKnuthMorrisPratt('ab', 'ggagbc')));
source array(4 bytes)
[$80,$80,$80,$80] =integer 0
[$80,$80,$80,$81] = 1
[$80,$80,$80,$FF] = 127
[$80,$80,$81,$01] = 128
need to convert this to integer.
below is my code and its working at the moment.
function convert(b: array of Byte): Integer;
var
i, st, p: Integer;
Negative: Boolean;
begin
result := 0;
st := -1;
for i := 0 to High(b) do
begin
if b[i] = $80 then Continue // skip leading 80
else
begin
st := i;
Negative := b[i] < $80;
b[i] := abs(b[i] - $80);
Break;
end;
end;
if st = -1 then exit;
for i := st to High(b) do
begin
p := round(Power(254, High(b) - i));
result := result + b[i] * p;
result := result - (p div 2);
end;
if Negative then result := -1 * result
end;
i'm looking for a better function?
Update:
file link
https://drive.google.com/file/d/0ByBA4QF-YOggZUdzcXpmOS1aam8/view?usp=sharing
in uploaded file ID field offset is from 5 to 9
NEW:
Now i got into new problem which is decoding date field
Date field hex [$80,$8F,$21,$C1] -> possible date 1995-12-15
* in uploaded file date field offset is from 199 to 203
Just an example of some improvements as outlined by David.
The array is passed by reference as a const.
The array is fixed in size.
The use of floating point calculations are converted directly into a constant array.
Const
MaxRange = 3;
Type
TMySpecial = array[0..MaxRange] of Byte;
function Convert(const b: TMySpecial): Integer;
var
i, j: Integer;
Negative: Boolean;
Const
// Pwr[i] = Round(Power(254,MaxRange-i));
Pwr: array[0..MaxRange] of Cardinal = (16387064,64516,254,1);
begin
for i := 0 to MaxRange do begin
if (b[i] <> $80) then begin
Negative := b[i] < $80;
Result := Abs(b[i] - $80)*Pwr[i] - (Pwr[i] shr 1);
for j := i+1 to MaxRange do
Result := Result + b[j]*Pwr[j] - (Pwr[j] shr 1);
if Negative then
Result := -Result;
Exit;
end;
end;
Result := 0;
end;
Note that less code lines is not always a sign of good performance.
Always measure performance before optimizing the code in order to find real bottlenecks.
Often code readability is better than optimizing over the top.
And for future references, please tell us what the algorithm is supposed to do.
Code for testing:
const
X : array[0..3] of TMySpecial =
(($80,$80,$80,$80), // =integer 0
($80,$80,$80,$81), // = 1
($80,$80,$80,$FF), // = 127
($80,$80,$81,$01)); // = 128
var
i,j: Integer;
sw: TStopWatch;
begin
sw := TStopWatch.StartNew;
for i := 1 to 100000000 do
for j := 0 to 3 do
Convert(X[j]);
WriteLn(sw.ElapsedMilliseconds);
ReadLn;
end.
I'm trying to read the install date from WMI (Win32_OperatingSystem.InstallDate). The return value looks like this: 20091020221246.000000+180. How can I get a valid Date?
Instead of parsing and extracting the values manually (how the accepted answer suggest), you can use the WbemScripting.SWbemDateTime object.
check this sample
function WmiDateToTDatetime(vDate : OleVariant) : TDateTime;
var
FWbemDateObj : OleVariant;
begin;
FWbemDateObj := CreateOleObject('WbemScripting.SWbemDateTime');
FWbemDateObj.Value:=vDate;
Result:=FWbemDateObj.GetVarDate;
end;
For more info about this topic you can read this artile WMI Tasks using Delphi – Dates and Times
MagWMI from Magenta Systems contains MagWmiDate2DT() that does this.
http://www.magsys.co.uk/delphi/magwmi.asp
System.Management.ManagementDateTimeConverter.ToDateTime
WbemScripting.SWbemDateTime does not always work. Better way:
function WmiDate2DT (S: string; var UtcOffset: integer): TDateTime ;
// yyyymmddhhnnss.zzzzzzsUUU +60 means 60 mins of UTC time
// 20030709091030.686000+060
// 1234567890123456789012345
var
yy, mm, dd, hh, nn, ss, zz: integer ;
timeDT: TDateTime ;
function GetNum (offset, len: integer): integer ;
var
E: Integer;
begin
Val (copy (S, offset, len), result, E) ;
end ;
begin
result := 0 ;
UtcOffset := 0 ;
if length (S) <> 25 then exit ; // fixed length
yy := GetNum (1, 4) ;
mm := GetNum (5, 2) ;
if (mm = 0) or (mm > 12) then exit ;
dd := GetNum (7, 2) ;
if (dd = 0) or (dd > 31) then exit ;
if NOT TryEncodeDate (yy, mm, dd, result) then // D6 and later
begin
result := -1 ;
exit ;
end ;
hh := GetNum (9, 2) ;
nn := GetNum (11, 2) ;
ss := GetNum (13, 2) ;
zz := 0 ;
if Length (S) >= 18 then zz := GetNum (16, 3) ;
if NOT TryEncodeTime (hh, nn, ss, zz, timeDT) then exit ; // D6 and later
result := result + timeDT ;
UtcOffset := GetNum (22, 4) ; // including sign
end ;
function VarDateToDateTime(const V: OleVariant): TDateTime;
var
rawdate: string ;
utcoffset: integer ;
begin
Result:=0;
if VarIsNull(V) then exit;
Dt.Value := V;
try
Result:=Dt.GetVarDate;
except
rawdate:=V;
result := WmiDate2DT (rawdate, utcoffset);
end;
end;
maybe this helps: http://technet.microsoft.com/en-us/library/ee156576.aspx