Delphi - Utilities

BIN String <--> Integer

Zulässige Typen sind: Integer, LongInt, Word, dWord, Byte und Short.

Bei der Übergabe und Rückgabe werden die Typen automatisch in Integer umgewandelt (der Typ Integer ist bei Delphi 3 immer 32 Bit Lang). Auf die Korrekte Stringlänge ist selbst zu achten. Leerzeichen können im String enthalten sein (dienen meist zur besseren Lesbarkeit) werden aber bei der Umwandlung ignoriert.

// Input: s1 = String mit Länge 1..32
// Output: Integer
Function BinStrToInt(s1:String):Integer;
Var i,i1:Integer;
Begin
  If Length(s1) > 0 Then Begin
    If s1[1] = '0' Then i1 := 0 Else i1 := 1;
    If Length(s1) > 1 Then Begin
      For i := 2 to Length(s1) do Begin
        If s1[i] <> ' ' Then Begin
          i1 := i1 shl 1;
          If s1[i] = '1' Then i1 := i1 or 1;
        End;
      End;
    End;
  End Else i1 := 0;
  Result := i1;
End;

// Input: i1 = Integer
// cnt = Länge des Bitstrings Byte, Short 1..8
// Integer, Word 1..16
// LingInt, dWord 1..32
// Leer = Fügt ein Space Zeichen ein
// 0 = Kein Leerzeichen
// 4 = Leerzeichen nach jeder 4ten Stelle
// Output: Binärstring
Function IntToBinStr(i1,cnt,Leer:Integer):String;
Var i,j,Mask:Integer; s1:String;
Begin
  s1 := '';
  Mask := 1;
  j := Leer;
  If cnt > 0 Then Begin
    For i := 1 to cnt do Begin
      If (i1 and Mask) = Mask Then s1 := '1' + s1 Else s1 := '0' + s1;
      Mask := Mask shl 1;
      If Leer > 0 Then Begin
        Dec(j);
        If j = 0 Then Begin
          s1 := ' ' + s1;
          j := Leer;
        End;
      End;
    End;
  End;
  s1 := Trim(s1);
  Result := s1;
End;

CRC 16 Bit berechnen

Polynom: Crc nach CCITT = x16 + x12 + x5 + 1

// Tabelle nach CCITT
Const Crc16Tab : Array[0..255] of Word = (
$0000, $1021, $2042, $3063, $4084, $50a5, $60c6, $70e7,
$8108, $9129, $a14a, $b16b, $c18c, $d1ad, $e1ce, $f1ef,
$1231, $0210, $3273, $2252, $52b5, $4294, $72f7, $62d6,
$9339, $8318, $b37b, $a35a, $d3bd, $c39c, $f3ff, $e3de,
$2462, $3443, $0420, $1401, $64e6, $74c7, $44a4, $5485,
$a56a, $b54b, $8528, $9509, $e5ee, $f5cf, $c5ac, $d58d,
$3653, $2672, $1611, $0630, $76d7, $66f6, $5695, $46b4,
$b75b, $a77a, $9719, $8738, $f7df, $e7fe, $d79d, $c7bc,
$48c4, $58e5, $6886, $78a7, $0840, $1861, $2802, $3823,
$c9cc, $d9ed, $e98e, $f9af, $8948, $9969, $a90a, $b92b,
$5af5, $4ad4, $7ab7, $6a96, $1a71, $0a50, $3a33, $2a12,
$dbfd, $cbdc, $fbbf, $eb9e, $9b79, $8b58, $bb3b, $ab1a,
$6ca6, $7c87, $4ce4, $5cc5, $2c22, $3c03, $0c60, $1c41,
$edae, $fd8f, $cdec, $ddcd, $ad2a, $bd0b, $8d68, $9d49,
$7e97, $6eb6, $5ed5, $4ef4, $3e13, $2e32, $1e51, $0e70,
$ff9f, $efbe, $dfdd, $cffc, $bf1b, $af3a, $9f59, $8f78,
$9188, $81a9, $b1ca, $a1eb, $d10c, $c12d, $f14e, $e16f,
$1080, $00a1, $30c2, $20e3, $5004, $4025, $7046, $6067,
$83b9, $9398, $a3fb, $b3da, $c33d, $d31c, $e37f, $f35e,
$02b1, $1290, $22f3, $32d2, $4235, $5214, $6277, $7256,
$b5ea, $a5cb, $95a8, $8589, $f56e, $e54f, $d52c, $c50d,
$34e2, $24c3, $14a0, $0481, $7466, $6447, $5424, $4405,
$a7db, $b7fa, $8799, $97b8, $e75f, $f77e, $c71d, $d73c,
$26d3, $36f2, $0691, $16b0, $6657, $7676, $4615, $5634,
$d94c, $c96d, $f90e, $e92f, $99c8, $89e9, $b98a, $a9ab,
$5844, $4865, $7806, $6827, $18c0, $08e1, $3882, $28a3,
$cb7d, $db5c, $eb3f, $fb1e, $8bf9, $9bd8, $abbb, $bb9a,
$4a75, $5a54, $6a37, $7a16, $0af1, $1ad0, $2ab3, $3a92,
$fd2e, $ed0f, $dd6c, $cd4d, $bdaa, $ad8b, $9de8, $8dc9,
$7c26, $6c07, $5c64, $4c45, $3ca2, $2c83, $1ce0, $0cc1,
$ef1f, $ff3e, $cf5d, $df7c, $af9b, $bfba, $8fd9, $9ff8,
$6e17, $7e36, $4e55, $5e74, $2e93, $3eb2, $0ed1, $1ef0
);

Function GenerateCRC16(Var s1:String):Word;
Var crc16:Word; i:Integer;
Begin
  crc16 := 0;
  For i := 1 to Length(s1) do Begin
    Crc16 := Crc16Tab[((Crc16 shr 8 ) xor Ord(s1[i])) and $ff] xor ((Crc16 shl 8) and $FFFF);
  End;
  Result := crc16;
End;

Procedure TForm1.Button1Click(Sender: TObject);
Var crc16:Word; s1,s2:String; i,j:Integer;
Begin
  s1 := '1234567890';
  For j := 1 to 10 do Begin
    s2 := Copy(s1,1,j);
    crc16 := GenerateCRC16(s2);
    Memo1.Lines.Add(IntToStr(j) + Chr(9) + IntToHex(crc16,4));
  End;
End;

Antworten:

 1 $2672
 2 $20B5
 3 $9752
 4 $D789
 5 $546C
 6 $20E4
 7 $86D6
 8 $9015
 9 $31C3
10 $D321

CRC 32 Bit berechnen

Const
Crc32Tab : Array[0..255] of LongInt = (
$00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
$e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
$09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
$f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
$136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
$fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
$3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
$dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
$26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
$cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
$2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
$98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
$7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
$91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
$6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
$8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
$4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
$a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
$44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
$be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
$5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
$b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
$ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
$0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
$f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
$196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
$f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
$38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
$d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
$316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
$cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
$2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
$9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
$72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
$92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
$68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
$88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
$616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
$a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
$40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
$bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
$54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
$b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
);

Function UpdateCrc32(value: Byte; crc: LongInt): LongInt;
Begin
  UpdateCrc32 := Crc32Tab[Byte(crc xor LongInt(value))] xor ((crc shr 8) and $00ffffff);
End;

procedure TForm1.Button1Click(Sender: TObject);
Var crc32:LongInt; s1:String; i,j:Integer;
Begin
  s1 := '1234567890';
  For j := 1 to 10 do Begin
    crc32 := 0;
    For i := 1 to j do Begin
      crc32 := UpdateCrc32(Ord(s1[i]),crc32);
    End;
    Memo1.Lines.Add(IntToStr(j) + Chr(9) + IntToHex(crc32,8));
  End;
End;

Antworten:

 1 $51DE003A
 2 $0E8A5632
 3 $7709BAC0
 4 $BAA73FBF
 5 $0DD7CD01
 6 $B8B072C2
 7 $CD6FB6E1
 8 $FFC205C6
 9 $2DFD2D88
10 $C597C693

CRC 32 für Dateien berechnen

Diese Unit wurde abgeleitet aus einem Fortran77 Programm von Aram Perez erschienen in "Byte-wise CRC Calculations" in IEEE Micro, Juni 1983, Seite 40-50. Die Konstanten sind für ein CRC-32 generator Polynom, wie es im Microsoft Systems Journal, März 1995, Seite 107-108 definiert wurde.

Const Table: Array [0..255] of LongInt =
 ($00000000, $77073096, $EE0E612C, $990951BA,
  $076DC419, $706AF48F, $E963A535, $9E6495A3,
  $0EDB8832, $79DCB8A4, $E0D5E91E, $97D2D988,
  $09B64C2B, $7EB17CBD, $E7B82D07, $90BF1D91,
  $1DB71064, $6AB020F2, $F3B97148, $84BE41DE,
  $1ADAD47D, $6DDDE4EB, $F4D4B551, $83D385C7,
  $136C9856, $646BA8C0, $FD62F97A, $8A65C9EC,
  $14015C4F, $63066CD9, $FA0F3D63, $8D080DF5,
  $3B6E20C8, $4C69105E, $D56041E4, $A2677172,
  $3C03E4D1, $4B04D447, $D20D85FD, $A50AB56B,
  $35B5A8FA, $42B2986C, $DBBBC9D6, $ACBCF940,
  $32D86CE3, $45DF5C75, $DCD60DCF, $ABD13D59,
  $26D930AC, $51DE003A, $C8D75180, $BFD06116,
  $21B4F4B5, $56B3C423, $CFBA9599, $B8BDA50F,
  $2802B89E, $5F058808, $C60CD9B2, $B10BE924,
  $2F6F7C87, $58684C11, $C1611DAB, $B6662D3D,

  $76DC4190, $01DB7106, $98D220BC, $EFD5102A,
  $71B18589, $06B6B51F, $9FBFE4A5, $E8B8D433,
  $7807C9A2, $0F00F934, $9609A88E, $E10E9818,
  $7F6A0DBB, $086D3D2D, $91646C97, $E6635C01,
  $6B6B51F4, $1C6C6162, $856530D8, $F262004E,
  $6C0695ED, $1B01A57B, $8208F4C1, $F50FC457,
  $65B0D9C6, $12B7E950, $8BBEB8EA, $FCB9887C,
  $62DD1DDF, $15DA2D49, $8CD37CF3, $FBD44C65,
  $4DB26158, $3AB551CE, $A3BC0074, $D4BB30E2,
  $4ADFA541, $3DD895D7, $A4D1C46D, $D3D6F4FB,
  $4369E96A, $346ED9FC, $AD678846, $DA60B8D0,
  $44042D73, $33031DE5, $AA0A4C5F, $DD0D7CC9,
  $5005713C, $270241AA, $BE0B1010, $C90C2086,
  $5768B525, $206F85B3, $B966D409, $CE61E49F,
  $5EDEF90E, $29D9C998, $B0D09822, $C7D7A8B4,
  $59B33D17, $2EB40D81, $B7BD5C3B, $C0BA6CAD,
  $EDB88320, $9ABFB3B6, $03B6E20C, $74B1D29A,

  $EAD54739, $9DD277AF, $04DB2615, $73DC1683,
  $E3630B12, $94643B84, $0D6D6A3E, $7A6A5AA8,
  $E40ECF0B, $9309FF9D, $0A00AE27, $7D079EB1,
  $F00F9344, $8708A3D2, $1E01F268, $6906C2FE,
  $F762575D, $806567CB, $196C3671, $6E6B06E7,
  $FED41B76, $89D32BE0, $10DA7A5A, $67DD4ACC,
  $F9B9DF6F, $8EBEEFF9, $17B7BE43, $60B08ED5,
  $D6D6A3E8, $A1D1937E, $38D8C2C4, $4FDFF252,
  $D1BB67F1, $A6BC5767, $3FB506DD, $48B2364B,
  $D80D2BDA, $AF0A1B4C, $36034AF6, $41047A60,
  $DF60EFC3, $A867DF55, $316E8EEF, $4669BE79,
  $CB61B38C, $BC66831A, $256FD2A0, $5268E236,
  $CC0C7795, $BB0B4703, $220216B9, $5505262F,
  $C5BA3BBE, $B2BD0B28, $2BB45A92, $5CB36A04,
  $C2D7FFA7, $B5D0CF31, $2CD99E8B, $5BDEAE1D,

  $9B64C2B0, $EC63F226, $756AA39C, $026D930A,
  $9C0906A9, $EB0E363F, $72076785, $05005713,
  $95BF4A82, $E2B87A14, $7BB12BAE, $0CB61B38,
  $92D28E9B, $E5D5BE0D, $7CDCEFB7, $0BDBDF21,
  $86D3D2D4, $F1D4E242, $68DDB3F8, $1FDA836E,
  $81BE16CD, $F6B9265B, $6FB077E1, $18B74777,
  $88085AE6, $FF0F6A70, $66063BCA, $11010B5C,
  $8F659EFF, $F862AE69, $616BFFD3, $166CCF45,
  $A00AE278, $D70DD2EE, $4E048354, $3903B3C2,
  $A7672661, $D06016F7, $4969474D, $3E6E77DB,
  $AED16A4A, $D9D65ADC, $40DF0B66, $37D83BF0,
  $A9BCAE53, $DEBB9EC5, $47B2CF7F, $30B5FFE9,
  $BDBDF21C, $CABAC28A, $53B39330, $24B4A3A6,
  $BAD03605, $CDD70693, $54DE5729, $23D967BF,
  $B3667A2E, $C4614AB8, $5D681B02, $2A6F2B94,
  $B40BBE37, $C30C8EA1, $5A05DF1B, $2D02EF8D);

Type TBuffer = Array [1..65521] of Byte;

Procedure CalcCRC32(Var p:TBuffer;nbyte:Word;Var CRCvalue:LongInt);
Var i:Integer;
Begin
  For i := 1 to nBYTE do Begin
    CRCvalue := (CRCvalue shr 8) xor Table[p[i] xor (CRCvalue and $000000FF)];
  End;
End;

Function CalcFileCRC32(FromName:String;
            Var IOBuffer:TBuffer;
            Var TotalBytes:LongInt;
            Var error:Integer):Integer;
Var BytesRead,CRCvalue:Integer; FromFile:File;
Begin
  FileMode := 0; {Read only}
  CRCValue := $FFFFFFFF;
  AssignFile(FromFile,FromName);
  {$I-} Reset(FromFile,1); {$I+}
  error := IOResult;
  If error = 0 Then Begin
    TotalBytes := 0;
    Repeat
      BlockRead(FromFile,IOBuffer,SizeOf(IOBuffer),BytesRead);
      CalcCRC32(IOBuffer,BytesRead,CRCvalue);
      Inc(TotalBytes,BytesRead)
    Until BytesRead = 0;
    CloseFile(FromFile);
  End;
  Result := not CRCvalue;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var Buf:TBuffer; crc,tb,err:Integer;
begin
  crc := CalcFileCRC32('r:Project1.exe',Buf,tb,err);
  Edit1.Text := IntToHex(crc,8);
end;

Datum Format String holen

Für WinNT:

Function GetDateFormatter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sShortDate');
  Finally
    Reg.Free;
  End;
End;

Für Win95:

Achtung: Der Eintrag sShortDate erscheint nur dann, wenn er von der Standard Länder Einstellung des Betriebssystem abweicht.

Function GetDateFormatter:String; Var Reg:TRegistry; begin Reg := TRegistry.Create; Try Reg.RootKey := HKEY_CURRENT_USER; Reg.OpenKey('\Control Panel\International', false); Result := Reg.ReadString('sShortDate'); Finally Reg.Free; End; End;

Für BDE:

Ist so nicht vorhanden. Muß aus einzelnen Angaben zusammengesetzt werden:

    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\DATE', false);

FOURDIGITYEAR true,false
LEADINGZEROD true,false
LEADINGZEROM true,false
SEPARATOR Char
MODE 0=MTJ, 1=TMJ, 2=JMT

FFT und IFFT

Const Analyse = 0;
      Synthese = 1;
      NoWindow = 0;
      Hanning = 1; // Hanning Fenster bei Analyse
      umni = 2; // Dreieck Fenster bei Analyse

Type Complex = Record re,im : Real End;
      RealArray = Array [0..8192] of Real;
      ComplexArray = Array [0..8192] of Complex;

{---------------------------------------------}
{ Erstellt : 11.05.92                         }
{ Input:  n     Anzahl der Stützpunkte        }
{               n = 2^2..2^10                 }
{         sp    analyse                       }
{               sp[x].re = Stützwerte         }
{         sp    synthese                      }
{               sp[x].re = cos Stützwerte     }
{               sp[x].im = sin Stützwerte     }
{         inv   = 0  Fourieranalyse           }
{               = 1  Fouriersynthese          }
{         fnt   = 0  nichts machen            }
{               = 1  Hanning Fenster          }
{ Output: sp    analyse                       }
{               sp[x].re Realanteil (cos)     }
{               sp[x].im Imaginäranteil (sin) }
{         sp    synthese                      }
{               sp[x].re Stützpunkte          }
{         pw    pw[x] Powerspektrum           }
{               pw[0] Offset                  }
{               pw[1] 1. Harmonische          }
{               pw[n/2-1] letzte Harmonische  }
{---------------------------------------------}
{         Auflösung im Zeitbereich            }
{                 tt [sec]                    }
{       Auflösung im Frequenzbereich          }
{            tf = 1/(tt*n) [Hz]               }
{ für n Stützwerte ergeben n/2-1 harmonische  }
{---------------------------------------------}
{    Programmlaufzeiten auf 486AT 33MHz       }
{    Simulierte Funktion: Rechteck 1 zu 10    }
{    4  0.001 Sekunden   128  0.055 Sekunden  }
{    8  0.002 Sekunden   256  0.110 Sekunden  }
{   16  0.005 Sekunden   512  0.275 Sekunden  }
{   32  0.011 Sekunden  1024  0.604 Sekunden  }
{   64  0.024 Sekunden  2048  1.319 Sekunden  }
{---------------------------------------------}
{ Programmlaufzeiten auf Pentium Pro 200 MHz  }
{    Simulierte Funktion: Rechteck 1 zu 10    }
{    4  0.064 mSek       128  2.876 mSek      }
{    8  0.117 mSek       256  6.385 mSek      }
{   16  0.255 mSek       512 13.988 mSek      }
{   32  0.586 mSek      1024 30.669 mSek      }
{   64  1.297 mSek      2048 67.173 mSek      }
{---------------------------------------------}
{ Programmlaufzeiten auf AMD Athlon 600 MHz   }
{    Simulierte Funktion: Rechteck 1 zu 10    }
{   4  0.021 mSek        128  0.862 mSek      }
{   8  0.038 mSek        256  1.876 mSek      }
{  16  0.076 mSek        512  4.097 mSek      }
{  32  0.184 mSek       1024  8.848 mSek      }
{  64  0.396 mSek       2048 19.039 mSek      }
{---------------------------------------------}
Procedure FFT(lnN:Integer; Var fr:ComplexArray; Var pw:RealArray; Fnt,Inv:Integer);
Var n,nd2,i,j,k,l,le,le1,ip:Integer;
    r1,u2,z1:Double;
    t1,u1,w1:Complex;
Begin
  n := 1;
  If lnN > 0 Then n := n shl lnN;
  nd2 := n shr 1;

  { Fensterfunktion }
  If Inv = Analyse Then Begin
    If Fnt = Hanning Then Begin { Hanning Fenster }
      For i := 0 to n-1 do Begin
        fr[i].re := fr[i].re * (0.5 - 0.5 * Cos(2.0 * pi * i / n));
      End;
    End;
    If Fnt = umni Then Begin { Dreieck Fenster }
      z1 := 2 / n;
      For i := 0 to (n div 2 - 1) do Begin
        fr[i].re := fr[i].re * i * z1;
      End;
      For i := (n div 2) to (n-1) do Begin
        fr[i].re := fr[i].re * (n - i) * z1;
      End;
    End;
  End;

  { Bitreversing }
  j := 1;
  For i := 1 to n-1 do Begin
    If i < j Then Begin
      r1 := fr[i].re; fr[i].re := fr[j].re; fr[j].re := r1;
      r1 := fr[i].im; fr[i].im := fr[j].im; fr[j].im := r1;
    End;
    k := nd2;
    While k < j do Begin
      j := j - k;
      k := k shr 1;
    End;
    j := j + k;
  End;

  { Start FFT }
  For l := 1 to lnN do Begin
    le := 1 shl l;
    le1 := le shr 1;
    u1.re := 1;
    u1.im := 0;
    z1 := pi / le1;
    If Inv = Analyse Then Begin
      w1.re := Cos(z1);
      w1.im := Sin(z1);
    End Else Begin
      w1.re := Cos(z1);
      w1.im := -Sin(z1);
    End;
    For j := 1 to le1 do Begin
      i := j;
      While i <= N do Begin
        ip := i + le1;
        t1.re := fr[ip].re * u1.re - fr[ip].im * u1.im;
        t1.im := fr[ip].re * u1.im + fr[ip].im * u1.re;
        fr[ip].re := fr[i].re - t1.re;
        fr[ip].im := fr[i].im - t1.im;
        fr[i].re := fr[i].re + t1.re;
        fr[i].im := fr[i].im + t1.im;
        i := i + le;
      End;
      u2 := u1.re * w1.re - u1.im * w1.im;
      u1.im := u1.re * w1.im + u1.im * w1.re;
      u1.re := u2;
    End;
  End;

  { Normierung der Frequenzanteile }
  If Inv = Analyse Then Begin
    t1.re := n;
    t1.im := 0.0;
    For i := 0 to n-1 do Begin
      r1 := t1.re * t1.re + t1.im * t1.im;
      fr[i].re := (fr[i].re * t1.re + fr[i].im * t1.im) / r1;
      fr[i].im := (t1.re * fr[i].im - fr[i].re * t1.im) / r1;
    End;
  End;

  { Powerspektrum }
  If Inv = Analyse Then Begin
    For i := 0 to n-1 do Begin
      pw[i] := Sqrt(fr[i].re * fr[i].re + fr[i].im * fr[i].im);
    End;
  End;

End;

procedure TForm1.Button1Click(Sender: TObject);
Var c,t1,t2:TLargeInteger;
    i:Integer; nn:Integer;
    sp:ComplexArray; pw:RealArray;
begin
  nn := 2048;
  For i := 0 to nn do Begin
    sp[i].im := 0;
    sp[i].re := 0;
    If i < nn div 10 Then sp[i].re := 10;
  End;
  QueryPerformanceFrequency(c);
  QueryPerformanceCounter(t1);
  FFT(11,sp,pw,NoWindow,Analyse);
  QueryPerformanceCounter(t2);
  Edit1.Text := FloatToStr(1000 * (t2.QuadPart - t1.QuadPart) / c.QuadPart);
end;

HEX String <--> Integer

s1 := IntToHex(i1,n);
n = Anzahl der HEX Stellen

i1 := StrToInt('$10AB');
Wichtig ist das $ Zeichen

Zulässige Typen sind: Integer, LongInt, Word, dWord, Byte und Short.

Bei der Übergabe und Rückgabe werden die Typen automatisch in Integer umgewandelt (der Typ Integer ist bei Delphi 3 immer 32 Bit Lang). Auf die Korrekte Stringlänge ist selbst zu achten. Leerzeichen können im String enthalten sein (dienen meist zur besseren Lesbarkeit) werden aber bei der Umwandlung ignoriert.

Function HexStrToInt(s1:String):Integer;
Var d1:Cardinal; b1:Byte; i:Integer;
Begin
  d1 := 0;
  For i := 1 to Length(s1) do Begin
    If s1[i] <> ' ' Then Begin
      d1 := d1 shl 4;
      b1 := Ord((s1[i])) - 48;
      If b1 > 41 Then b1 := b1 - 32;
      If b1 > 9 Then b1 := b1 - 7;
      d1 := d1 or b1;
    End;
  End;
  Result := d1;
End;

Function IntToHexStr(i1,cnt,Leer:Integer):String;
Var i,j:Integer; s1:String;
Begin
  s1 := IntToHex(i1,cnt);
  If Leer > 0 Then Begin
    For i := 1 to (Length(s1)-1 div Leer) do Begin
      Insert(' ',s1,i * Leer + i);
    End;
  End;
  Result := Trim(s1);
End;

HEX String <--> Double

Function DoubleToHexStr(d1:Double; Leer:Integer):String;
Type pArray = Array [0..7] of Byte;
Var Tmp:^pArray; s1:String; i:Integer;
Begin
  s1 := '';
  Tmp := @d1;
  For i := 0 to 7 do Begin
    s1 := s1 + IntToHexStr(Tmp^[i],2,0);
  End;
  If Leer > 0 Then Begin
    For i := 1 to (Length(s1)-1 div Leer) do Begin
      Insert(' ',s1,i * Leer + i);
    End;
  End;
  Result := s1;
End;

Function HexStrToDouble(s1:String):Double;
Type pArray = Array [0..7] of Byte;
Var Tmp:pArray; s2:String; i:Integer; r1: ^Double;
Begin
  r1 := @Tmp;
  // Alle Leerzeichen entfernen
  For i := 1 to Length(s1) do Begin
    If s1[i] = ' ' Then Delete(s1,i,1);
  End;
  // String muß jetzt 16 Zeichen lang sein
  If Length(Trim(s1)) = 16 Then Begin
    Tmp[0] := Byte(HexStrToInt(Copy(s1,1,2)));
    Tmp[1] := Byte(HexStrToInt(Copy(s1,3,2)));
    Tmp[2] := Byte(HexStrToInt(Copy(s1,5,2)));
    Tmp[3] := Byte(HexStrToInt(Copy(s1,7,2)));
    Tmp[4] := Byte(HexStrToInt(Copy(s1,9,2)));
    Tmp[5] := Byte(HexStrToInt(Copy(s1,11,2)));
    Tmp[6] := Byte(HexStrToInt(Copy(s1,13,2)));
    Tmp[7] := Byte(HexStrToInt(Copy(s1,15,2)));
    Result := r1^;
  End Else Result := 0;
End;

HEX String <--> Single

Function SingleToHexStr(d1:Single; Leer:Integer):String;
Type pArray = Array [0..3] of Byte;
Var Tmp:^pArray; s1:String; i:Integer;
Begin
  s1 := '';
  Tmp := @d1;
  For i := 0 to 3 do Begin
    s1 := s1 + IntToHexStr(Tmp^[i],2,0);
  End;
  If Leer > 0 Then Begin
    For i := 1 to (Length(s1)-1 div Leer) do Begin
      Insert(' ',s1,i * Leer + i);
    End;
  End;
  Result := s1;
End;

Function HexStrToSingle(s1:String):Single;
Type pArray = Array [0..3] of Byte;
Var Tmp:pArray; s2:String; i:Integer; r1: ^Single;
Begin
  r1 := @Tmp;
  // Alle Leerzeichen entfernen
  For i := 1 to Length(s1) do Begin
    If s1[i] = ' ' Then Delete(s1,i,1);
  End;
  // String muß jetzt 8 Zeichen lang sein
  If Length(Trim(s1)) = 8 Then Begin
    Tmp[0] := Byte(HexStrToInt(Copy(s1,1,2)));
    Tmp[1] := Byte(HexStrToInt(Copy(s1,3,2)));
    Tmp[2] := Byte(HexStrToInt(Copy(s1,5,2)));
    Tmp[3] := Byte(HexStrToInt(Copy(s1,7,2)));
    Result := r1^;
  End Else Result := 0;
End;

Ist Das Jahr ein Schaltjahr

Gültig für Datum ab 15.10.1582

0=Kein Schaltjahr

1=Schaltjahr

Function Schaltjahr(t1:TDateTime):Integer;
Var Jahr:Integer;
Begin
  Result := 0;
  Jahr := StrToInt(FormatDateTime('yyyy',t1));
  If (Jahr mod 4) = 0 Then Result := 1;
  If (Jahr mod 100) = 0 Then Result := 0;
  If (Jahr mod 400) = 0 Then Result := 1;
End;

Ist String ein BIN ?

Leerzeichen im String werden ignoriert.

// Input:  s1 = Binärer String
// Output: true wenn alle Zeichen 0 oder 1 sind
//         false wenn ein anderes Zeichen enthalten ist
Function IsBin(s1:String):Boolean;
Var i:Integer;
Begin
  Result := true;
  If Length(s1) > 0 Then Begin
    For i := 1 to Length(s1) do Begin
      If not (s1[i] in [' ','0','1']) Then Begin
        Result := false;
        Break;
      End;
    End;
  End Else Result := false;
End;

Ist String ein Datum ?

Function IsDate(s1:String):Boolean;
Var i,k,p1,p2:Integer; sm,sd,sj,ss:String;
Begin
  Result := false;
  ss := GetDateDelimiter;
  k := Length(s1);
  If k > 0 Then Begin
    p1 := 0;
    p2 := 0;
    For i := 1 to k do Begin
      If p1 = 0 Then Begin
        If s1[i] = ss Then p1 := i;
      End Else Begin
        If s1[i] = ss Then p2 := i;
      End;
    End;
    If p1 > 0 Then Begin
      If p2 > 0 Then Begin
        If p2 > p1 Then Begin
          sm := Copy(s1,1,p1-1);
          sd := Copy(s1,p1+1,p2-p1-1);
          sj := Copy(s1,p2+1,k-p2);
          If IsNumeric(sm) Then Begin
            If IsNumeric(sd) Then Begin
              If IsNumeric(sj) Then Begin
                p1 := StrToInt(sd);
                If (p1 > 0) and (p1 < 32) Then Begin
                  p1 := StrToInt(sm);
                  If (p1 > 0) and (p1 < 13) Then Begin
                    p1 := StrToInt(sj);
                    If p1 > 1969 Then Result := true;
                  End;
                End;
              End;
            End;
          End;
        End;
      End;
    End;
  End;
End;

Ist String ein HEX ?

Leerzeichen im String werden ignoriert.

Function IsHex(s1:String):Boolean;
Var i:Integer;
Begin
  Result := true;
  If Length(s1) > 0 Then Begin
    For i := 1 to Length(s1) do Begin
      If not (s1[i] in [' ','0'..'9','a'..'f','A'..'F']) Then Begin
        Result := false;
        Break;
      End;
    End;
  End Else Result := false;
End;

Ist String ein Integer ?

Leerzeichen im String sind nicht erlaubt.

Function IsInt(s1:String):Boolean;
Var i:Integer;
Begin
  Result := true;
  If Length(s1) > 0 Then Begin
    For i := 1 to Length(s1) do Begin
      If not (s1[i] in ['0'..'9']) Then Begin
        Result := false;
        Break;
      End;
    End;
  End Else Result := false;
End;

Ist String eine Zeit ?

Function IsTime(s1:String):Boolean;
Var i,k,p1,p2:Integer; sStd,sMin,sSec,ss:String;
Begin
  Result := false;
  ss := GetTimeDelimiter;
  k := Length(s1);
  If k > 0 Then Begin
    p1 := 0;
    p2 := 0;
    For i := 1 to k do Begin
      If p1 = 0 Then Begin
        If s1[i] = ss Then p1 := i;
      End Else Begin
        If s1[i] = ss Then p2 := i;
      End;
    End;
    If p1 > 0 Then Begin
      If p2 > 0 Then Begin
        If p2 > p1 Then Begin
          sStd := Copy(s1,1,p1-1);
          sMin := Copy(s1,p1+1,p2-p1-1);
          sSec := Copy(s1,p2+1,k-p2);
          If IsNumeric(sStd) Then Begin
            If IsNumeric(sMin) Then Begin
              If IsNumeric(sSec) Then Begin
                p1 := StrToInt(sStd);
                If (p1 >= 0) and (p1 < 24) Then Begin
                  p1 := StrToInt(sMin);
                  If (p1 >= 0) and (p1 < 60) Then Begin
                    p1 := StrToInt(sSec);
                    If (p1 >= 0) and (p1 < 60) Then Result := true;
                  End;
                End;
              End;
            End;
          End;
        End;
      End;
    End;
  End;
End;

Ist String Numerisch ?

Leerzeichen im String sind nicht erlaubt.

Function IsNumeric(s1:String):Boolean;
Var ier:Integer; r1:Real;
Begin
  Result := true;
  Val(s1,r1,ier);
  If ier > 0 Then Result := false;
End;

Juian <--> Date

Gültig für den Gregorianischen Kalender ab dem 02.02.0000

02.02.0000 = 1721092

01.01.1000 = 2086303

01.03.1999 = 2451239

01.01.2000 = 2451545

Datumsformat = 'DD.MM.YYYY'

Function JulianToDate(jd:LongInt):String;
Var z,a,b,c: Integer;
    r,g: Double;
    Year,Month,Day: Integer;
    s1,s2,s3: String;
Begin
  z := Floor(jd - 1721118.5);
  r := jd - 1721118.5 - z;
  g := z - 0.25;
  a := Floor(g / 36524.25);
  b := a - Floor(a / 4);
  Year := Floor((b + g) / 365.25);
  c := b + z - Floor(365.25 * Year);
  Month := (5 * c + 456) div 153;
  Day := c - ((153 * Month - 457) div 5 + Floor(r));
  If Month > 12 Then Begin
    Year := Year + 1;
    Month := Month - 12;
  End;
  s1 := IntToStr(Day);
  If Day < 10 Then s1 := '0' + s1;
  s2 := IntToStr(Month);
  If Month < 10 Then s2 := '0' + s2;
  s3 := IntToStr(Year);
  If Year < 1000 Then s3 := '0' + s3;
  If Year < 100 Then s3 := '0' + s3;
  If Year < 10 Then s3 := '0' + s3;
  Result := s1 + '.' + s2 + '.' + s3;
End;

Function DateToJulian(s1:String):Double;
Var D,M,Y: LongInt;
    ier: Integer;
Begin
  Val(Copy(s1,1,2),D,ier);
  Val(Copy(s1,4,2),M,ier);
  Val(Copy(s1,7,4),Y,ier);
  If M < 3 Then Begin
    M := M + 12;
    Y := Y - 1;
  End;
  Result := D + (153 * M - 457) / 5 + 365 * Y + Y div 4 - Y div 100 + Y div 400 + 1721118.5;
End;

procedure TForm1.Button1Click(Sender: TObject);
begin
  Edit2.Text := JulianToDate(StrToInt(Edit1.Text));
end;

procedure TForm1.Button2Click(Sender: TObject);
begin
  Edit1.Text := IntToStr(Round(DateToJulian(Edit2.Text)));
end;

Um diese Routine zu benutzen, muß die Unit Math in Uses stehen.

Uses Math,...;

Ist die Unit Math nicht verfügbar dann kann Floor auch ersetzt werden durch:

function Floor(X: Extended): Integer;
begin
  Result := Trunc(X);
  if Frac(X) < 0 then Dec(Result);
end;

Kalenderwoche berechnen

Gültig für Datum ab 15.10.1582

Function KalenderWoche(t1:TDateTime):Integer;
Var t,w,b,c,kw:Integer; t2:TDateTime;
begin
  t := DayOfYear(t1);
  t2 := StrToDate('01/01/'+ Copy(DateToStr(t1),7,4));
  w := DayOfWeek(t2);
  If w > 4 Then b := 2 Else b := -5;
  c := b - w;
  Result := (t - c) div 7;
end;

Bemerkungen zur Berechnung der Wochennummer nach DIN 1355:

Little Endian <--> Big Endian

Big Endian Format (Motorola 680x0) $1234ABCD interne Darstellung

Little Endian Format (Intel x86) $CDAB3412 interne Darstellung

Umwandlung für Word und Integer:

Function SwapInt(i1:Integer):Integer;
Begin
  Result := Swap(i1);
End;

Umwandlung für dWord und LongInt:

Function SwapLong(i1:Integer):Integer;
Type pArray = Array [0..3] of Byte;
Var Tmp: ^pArray; it: Byte; i:Integer;
Begin
  Tmp := @i1;
  For i := 0 to 1 do Begin
    it := Tmp^[i];
    Tmp^[i] := Tmp^[3-i];
    Tmp^[3-i] := it;
  End;
  Result := i1;
End;

Umwandlung für Single:

Function SwapSingle(i1:Single):Single;
Type pArray = Array [0..3] of Byte;
Var Tmp: ^pArray; it: Byte; i:Integer;
Begin
  Tmp := @i1;
  For i := 0 to 1 do Begin
    it := Tmp^[i];
    Tmp^[i] := Tmp^[3-i];
    Tmp^[3-i] := it;
  End;
  Result := i1;
End;

Umwandlung für Double:

Function SwapDouble(i1:Double):Double;
Type pArray = Array [0..7] of Byte;
Var Tmp: ^pArray; it: Byte; i:Integer;
Begin
  Tmp := @i1;
  For i := 0 to 3 do Begin
    it := Tmp^[i];
    Tmp^[i] := Tmp^[7-i];
    Tmp^[7-i] := it;
  End;
  Result := i1;
End;

Parser

Const MaxInCnt = 10;

Var InBuf: String;
    InPara: Array [1..MaxInCnt] of String[16];
    InCnt: Integer;


Function CheckDelimeter(c1:Char;s1:String):Boolean;
Var i:Integer;
Begin
  Result := false;
  For i := 1 to Length(s1) do Begin
    If c1 = s1[i] Then Begin
      Result := true;
      Break;
    End;
  End;
End;

Function ParseInBuf(dm:String):Integer;
Var i,i1:Integer; b1:Boolean;
Begin
  i := 0;
  b1 := true;
  InCnt := 0;
  If Length(InBuf) > 0 Then Begin
    Repeat
      i := i + 1;
      If b1 Then Begin
        // Argumentanfang erkennen
        If not CheckDelimeter(InBuf[i],dm) Then Begin
          i1 := i;
          b1 := false;
        End;
        // Sonderfall
        // Letztes Element der Zeile ist nur ein Zeichen lang
        If i1 = Length(InBuf) Then Begin
          InCnt := InCnt + 1;
          InPara[InCnt] := Copy(InBuf,i1,i-i1+1);
          i := MaxInt;
        End;
      End Else Begin
        // Argumentende erkennen
        If CheckDelimeter(InBuf[i],dm) Then Begin
          InCnt := InCnt + 1;
          InPara[InCnt] := Copy(InBuf,i1,i-i1);
          b1 := true;
        End Else Begin
          // Sonderfall
          // Delimeter am Zeilenende
          If i = Length(InBuf) Then Begin
            InCnt := InCnt + 1;
            InPara[InCnt] := Copy(InBuf,i1,i-i1+1);
            i := MaxInt;
          End;
        End;
        // Anzahl der Elemente ist begrenzt
        // Weitere Elemente werden ignoriert
        If InCnt > MaxInCnt Then Begin
          InCnt := MaxInCnt;
          i := MaxInt;
        End;
      End;
    Until i >= Length(InBuf);
  End;
  Result := InCnt;
End;

procedure TForm1.Button1Click(Sender: TObject);
Var i:Integer;
begin
  InBuf := Edit1.Text;
  i := ParseInBuf(' .:');
  If i > 0 Then Begin
    For i := 1 to InCnt do Begin
      Memo1.Lines.Add(InPara[i]);
    End;
  End;
end;

Regressionsanalyse

Type ValueRec = Record
       x: Double;
       y: Double;
     End;

Type ValueArray = Array [1..256] of ValueRec;

Var Values: ValueArray;

// Regressionsanalyse
// Art = 1 y = A + B * x
// = 2 y = A + B * ln(x)
// = 3 y = A * e^(B*x) [ln(y) = ln(A) + b * x]
// = 4 y = A * x^B [ln(y) = ln(A) + B * ln(x)]
// n = Anzahl der Werte im Array Vals
// A = Konstantenterm
// B = Regressionskoeffizient
// R = Korrelationskoeffizient
// R2 = Kritischer Koeefizient
// K = Kovarianz
Procedure Regression(Vals:ValueArray;n,Art:Integer;Var a,b,r,r2,k:Double);
Var i:Integer;
    sx,sy,sxy,sx2,sy2,tx,ty: Double;
Begin
  sx := 0;
  sy := 0;
  sxy := 0;
  sx2 := 0;
  sy2 := 0;
  For i := 1 to n do Begin
    Case Art of
      1: Begin tx := Vals[i].x; ty := Vals[i].y End;
      2: Begin tx := ln(Vals[i].x); ty := Vals[i].y End;
      3: Begin tx := Vals[i].x; ty := ln(Vals[i].y) End;
      4: Begin tx := ln(Vals[i].x); ty := ln(Vals[i].y) End;
    End;
    sx := sx + tx;
    sy := sy + ty;
    sxy := sxy + tx * ty;
    sx2 := sx2 + tx * tx;
    sy2 := sy2 + ty * ty;
  End;
  b := (n * sxy - sx * sy) / (n * sx2 - sx * sx);
  a := (sy - b * sx) / n;
  Case Art of
    3: a := Exp(a);
    4: a := Exp(a);
  End;
  r := (n * sxy - sx * sy) / Sqrt(Abs(n * sx2 - sx * sx) * Abs(n * sy2 - sy * sy));
  r2 := r * r;
  k := (sxy - sx * sy / n) / (n - 1);
End;

Testergebnisse

x

y

Lineare Regression
10
15
20
25
30
1003
1005
1010
1011
1014
A = 997.4
B = 0.56
R = 0.982607368881035
R2 = 0,96551724137931
K = 35

x

y

Logarithmische Regression
29
50
74
103
118
1.6
23.5
38.0
46.4
48.9
A = -111,128397647367
B = 34,0201475016053
R = 0,994013946616569
R2 = 0,988063726068247
K = 11,0718711446735

x

y

Exponentielle Regression
6.9
12.9
19.8
26.7
35.1
21.4
15.7
12.1
8.5
5.2
A = 30,4975874258554
B = -0,04920370830766
R = -0,99724735198775
R2 = 0,994502281046587
K = -6,08364490257618

x

y

Potenzielle Regression
28
30
33
35
38
2410
3033
3895
4491
5717
A = 0,238801068533404
B = 2,77186615763815
R = 0,998906255123585
R2 = 0,997813706525025
K = 0,0406994635705285

Shellsort up and down

Die zu sortierenden Strings liegen alle in einer Stringliste die als Variable übergeben wird.

Procedure ShellSortUp(Var A:TStrings);
Var ab,an,i,j,k:Integer; es:Boolean; en:String;
Begin
  ab := (A.Count div 2) * 2 div 2 - 1;
  While ab > 0 do Begin
    an := A.Count div ab;
    For i := 1 to ab do Begin
      For j := 1 to an-1 do Begin
        en := A[i+j*ab-1];
        k := i + (j - 1) * ab;
        es := false;
        While not(es) and (k > 0) do Begin
          If en >= A[k-1] Then es := true Else Begin
            A.Move(k+ab-1,k-1);
            dec(k,ab);
          End;
        End;
        A[k+ab-1] := en;
      End;
    End;
    ab := ab div 2;
  end;
End;

Procedure ShellSortDown(Var A:TStrings);
Var ab,an,i,j,k:Integer; es:Boolean; en:String;
Begin
  ab := (A.Count div 2) * 2 div 2 - 1;
  While ab > 0 do Begin
    an := A.Count div ab;
    For i := 1 to ab do Begin
      For j := 1 to an-1 do Begin
        en := A[i+j*ab-1];
        k := i + (j - 1) * ab;
        es := false;
        While not(es) and (k > 0) do Begin
          If en < A[k-1] Then es := true Else Begin
            A.Move(k+ab-1,k-1);
            dec(k,ab);
          End;
        End;
        A[k+ab-1] := en;
      End;
    End;
    ab := ab div 2;
  end;
End;

Tag einer Woche berechnen

Gültig für Datum ab 15.10.1582

0=So
1=Mo
2=Di
3=Mi
4=Do
5=Fr
6=Sa

Function DayOfWeek(t1:TDateTime):Integer;
Var a,b,Jahr,Days:Integer;
Begin
  Jahr := StrToInt(FormatDateTime('yyyy',t1));
  Days := DayOfYear(t1);
  a := (Jahr - 1) mod 100;
  b := (Jahr - 1) div 100;
  Result := (28+a+Days+(a div 4)+(b div 4)+5*b) mod 7;
End;

Tag eines Jahres berechnen

Gültig für Datum ab 15.10.1582

Function DayOfYear(t1:TDateTime):Integer;
Var s1:String; d,e,Tag,Monat:Integer;
Begin
  s1 := FormatDateTime('dd.mm.yyyy',t1);
  Tag := StrToInt(Copy(s1,1,2));
  Monat := StrToInt(Copy(s1,4,2));
  d := (Monat + 10) div 13;
  e := Tag + (611 * (Monat + 2)) div 20 - 2 * d - 91;
  Result := e + Schaltjahr(t1) * d;
End;

Trennzeichen Datum holen

Trennzeichen für alle:

Function GetDateDelimiter:String;
Var s1:String; i:Integer;
Begin
  s1 := DateTimeToStr(Now);
  For i := 1 to Length(s1) do Begin
    If Not (s1[i] in ['0'..'9']) Then Begin
      Result := s1[i];
      Break;
    End;
  End;
End;

Trennzeichen für WinNT:

Function GetDateDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sDate');
  Finally
    Reg.Free;
  End;
End;

Trennzeichen für Win95:

Achtung: Der Eintrag sDate erscheint nur dann, wenn er von der Standard Länder Einstellung des Betriebssystem abweicht.

Function GetDateDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Copy(Reg.ReadString('sDate'),3,1);
  Finally
    Reg.Free;
  End;
End;

Trennzeichen für BDE:

Function GetDateDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\DATE', false);
    Result := Reg.ReadString('SEPARATOR');
  Finally
    Reg.Free;
  End;
End;

Trennzeichen Dezimal holen

Trennzeichen für alle:

Function GetDecimalDelimiter:String;
Var s1:String;
Begin
  s1 := FloatToStr(pi);
  Result := s1[2];
End;


Trennzeichen für WinNT:

Function GetDecimalDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sDecimal');
  Finally
    Reg.Free;
  End;
End;


Trennzeicheen für Win95:


Achtung: Der Eintrag sDecimal erscheint nur dann, wenn er von der Standard Länder Einstellung des Betriebssystem abweicht.

Function GetDecimalDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sDecimal');
  Finally
    Reg.Free;
  End;
End;


Trennzeichen für die BDE:

Function GetDecimalDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_LOCAL_MACHINE;
    Reg.OpenKey('\SOFTWARE\Borland\Database Engine\Settings\SYSTEM\FORMATS\NUMBER', false);
    Result := Reg.ReadString('DECIMALSEPARATOR');
  Finally
    Reg.Free;
  End;
End;

Trennzeichen Zeit holen

Trennzeichen für alle:

Function GetTimeDelimiter:String;
Var s1:String; i:Integer;
Begin
  s1 := DateTimeToStr(Now);
  For i := Length(s1) downto 1 do Begin
    If Not (s1[i] in ['0'..'9']) Then Begin
      Result := s1[i];
      Break;
    End;
  End;
End;

Trennzeichen für WinNT:

Function GetTimeDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sTime');
  Finally
    Reg.Free;
  End;
End;


Trennzeichen für Win95:

Achtung: Der Eintrag sDecimal erscheint nur dann, wenn er von der Standard Länder Einstellung des Betriebssystem abweicht.

Function GetTimeDelimiter:String;
Var Reg:TRegistry;
begin
  Reg := TRegistry.Create;
  Try
    Reg.RootKey := HKEY_CURRENT_USER;
    Reg.OpenKey('\Control Panel\International', false);
    Result := Reg.ReadString('sTime');
  Finally
    Reg.Free;
  End;
End;


Trennzeicheen für BDE:

Ist immer ':'

Unix <--> PC Zeit

Unix Time zählt ab 01.01.1970 00:00:00 die Anzahl der Sekunden in einem LongInteger.
0 ... 2147483647 Sekunden = 01.02.1970 00:00:00 ... 18.01.2038 03:08:07

PC Time zählt ab 30.12.1899 00:00:00 die Tage.Sekunden als Real.
1 Tag = 86400 Sekunden --> 1 Sekunde = 1/86400 = 0.00001157407407407

Um bei Umwandlungen die PC-Routinen zu benutzen wird mit der Differenz von 25569 Tagen gerechnet.
25569 Tage: DateTimeToStr(25569) --> '01.01.1970 00:00:00'

Type UnixTime: dWord;

Function UnixIntToPcInt(Time:UnixTime):TDateTime;
Begin
  Result := Time / 86400 + 25569;
End;

Function UnixIntToPcStr(Time:UnixTime):String;
Begin
  Result := FormatDateTime('MM/DD/YYYY hh:mm:ss',Time / 86400 + 25569);
End;

Function UnixStrToPcInt(Time:String):TDateTime;
Begin
  Result := StrToInt(Time) / 86400 + 25569;
End;

Function UnixStrToPcStr(Time:String):String;
Begin
  Result := FormatDateTime('MM/DD/YYYY hh:mm:ss',StrToInt(Time) / 86400 + 25569);
End;

Function PcIntToUnixInt(Time:TDateTime):UnixTime;
Var l1:UnixTime; l2:Double;
Begin
  l2 := (Time - 25569) * 86400;
  l1 := Round(l2);
  If Frac(l2) >= 0.5 Then l1 := l1 - 1; { Rundungsfehler ausgleichen }
  Result := l1;
End;

Function PcIntToUnixStr(Time:TDateTime):String;
Var l1:UnixTime; l2:Double;
Begin
  l2 := (Time - 25569) * 86400;
  l1 := Round(l2);
  If Frac(l2) >= 0.5 Then l1 := l1 - 1; { Rundungsfehler ausgleichen }
  Result := IntToStr(l1);
End;

Function PcStrToUnixInt(Time:String):UnixTime;
Var l1:UnixTime; l2:Double;
Begin
  l2 := (StrToDateTime(Time) - 25569) * 86400;
  l1 := Round(l2);
  If Frac(l2) >= 0.5 Then l1 := l1 - 1; { Rundungsfehler ausgleichen }
  Result := l1;
End;

Function PcStrToUnixStr(Time:String):String;
Var l1:UnixTime; l2:Double;
Begin
  l2 := (StrToDateTime(Time) - 25569) * 86400;
  l1 := Round(l2);
  If Frac(l2) >= 0.5 Then l1 := l1 - 1; { Rundungsfehler ausgleichen }
  Result := IntToStr(l1);
End;