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;
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
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
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;
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
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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;
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:
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;
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;
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 |
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;
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;
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 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 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 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 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;