DBR Delphi-Ecke

// Double-Zahlen und Hex-Strings werden hin und her gewandelt.
// Es wird bei der Umwandlung der Strings beachtet, dass sie
// kürzer oder länger als benötigt sein könnten, falsche Zeichen
// enthalten könnten oder dass das Ergebnis MaxDouble bzw. MinDouble
// überschreiten könnte.

// Getestet mit D4 unter WinME

 
function DoubleToHex(d: double): string;  
var  
  p: ^byte;  
  x: integer;  
begin  
  p := @d;  
  result := '';  
  for x := 1 to sizeof(double) do begin  
    result := result + inttohex(p^, 2);  
    inc(p);  
  end;  
end;  
  
function HexToDouble(s: string; var d: double): boolean;  
var  
  p: ^byte;  
  x: integer;  
  hlp: Int64;  
  b: byte;  
begin  
  result := false;  
  if odd(length(s)) then s := '0' + s;  
  if (length(s) > sizeof(double) * 2) then exit;  
  p := @hlp;  
  for x := length(s) div 2 to sizeof(double) - 1 do begin  
    p^ := 0;  
    inc(p);  
  end;  
  x := 1;  
  try  
    while x < length(s) do begin  
      b := strtoint('$' + copy(s, x, 2));  
      p^ := b;  
      inc(p);  
      inc(x, 2);  
    end;  
  except  
    exit;  
  end;  
  if ((hlp and $7FF0000000000000) shr 52 = 2047)  
    and ((hlp and $FFFFFFFFFFFFF) > 0) then exit;  
  move(hlp, d, sizeof(double));  
  result := true;  
end;  
  
 
// --- Beispielaufrufe ---  
  
procedure TFormx.Button2Click(Sender: TObject);  
var  
  d: double;   
begin  
  d := -1.2345678E305;  
  showmessage(DoubleToHex(d));  
end;  
  
procedure TFormx.Button3Click(Sender: TObject);  
var  
  d: double;  
  s: string;  
begin  
  s := 'DB7AEED4E28046FF';  
  if not HexToDouble(s, d) then  
    showmessage('Fehler') else  
    showmessage(floattostr(d));  
end;  
 
// ---------------------------------------------

// Geringfügige Änderung bei D2010 unter W10
// Sollte auch für AnsiStrings funktionieren.

function HexToDouble(s: string; var d: double): boolean; 
var 
  p: ^byte; 
  x: integer; 
  hlp: Int64; 
  b: byte; 
begin 
  result := false; 
  if odd(length(s)) then 
    s := '0' + s; 
  if (length(s) > sizeof(double) * 2) then 
    exit; 
  hlp := 0; 
  p := @hlp; 
  x := 1; 
  try 
    while x < length(s) do 
    begin 
      b := strtoint('$' + copy(s, x, 2)); 
      p^ := b; 
      inc(p); 
      inc(x, 2); 
    end; 
  except 
    exit; 
  end; 
  if ((hlp and $7FF0000000000000) shr 52 = 2047) and 
    ((hlp and $FFFFFFFFFFFFF) > 0) then 
    exit; 
  move(hlp, d, sizeof(double)); 
  result := true; 
end;