[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]

    {*******************************************************}
    {                                                       }
    {       xTool - Component Collection                    }
    {                                                       }
    {       Copyright (c) 1995 Stefan Böther                }
    {                            stefc@fabula.com           }
    {*******************************************************}
    {
      Please look also for our xTools-Nails function toolkit.
      More information you'll find under
        http://ourworld.compuserve.com/homepages/stefc/xprocs.htm

      Any comments and enhancements are welcome, if the're
      sended to  stefc@fabula.com.

       21.02.96  added TMonth & TDay type                                Stefc
       22.02.96  added strFileLoad & strFileSave                         Stefc
       09.03.96  correct sysTempPath                                     Stefc
       09.03.96  added regXXXXX functions for access the registry        Stefc
       24.03.96  added IsWinNT constant                                  Stefc
       24.03.96  added SysMetric object                                  Stefc
       26.03.96  added dateQuicken for controling date input with keys   Stefc
       27.03.96  added TDesktopCanvas here                               Stefc
       28.03.96  added LoadDIBitmap                                      Stefc
       01.04.96  added Question function here                            Stefc
       09.04.96  added sysSaverRunning added                             Stefc
       12.04.96  added timeZoneOffset                                    Stefc
       12.04.96  added timeToInt                                         Stefc
       17.04.96  added strCmdLine                                        Stefc
       17.04.96  added rectBounds                                        Stefc
       17.04.96  added TPersistentRect class                             Stefc
       19.04.96  added strDebug method                                   Stefc
       21.04.96  changed TMonth added noneMonth                          km
       21.04.96  added licence callback                                  Stefc
       21.04.96  added strNiceDateDefault                                km
       21.04.96  added simple strEncrpyt & strDecrypt                    Stefc
       24.04.96  backport to 16 bit                                      Stefc
       24.04.96  added Information method                                Stefc
       24.04.96  use win messageBox with Win95 in Question & Information Stefc
       09.05.96  new function ExtractName                                Stefc
       10.05.96  Added TPersistentRegistry                               Stefc
       12.05.96  fileExec                                                Stefc
       14.05.96  New function Confirmation                               Stefc
       16.05.96  New function strChange                                  Stefc
       29.05.96  New functions comXXXXX                                  Stefc
       09.06.96  New function strSearchReplace                           km
       09.06.96  ported assembler strHash to plain pascal                Stefc
       15.06.96  new variables xLanguage & xLangOfs                      Stefc
       28.06.96  new method sysBeep                                      Stefc
       28.06.96  new method intPercent                                   Stefc
       10.07.96  make compatible with 16 Bit Delphi 1.0                  Stefc
       14.07.96  fileLongName & fileShortName defined                    Stefc
       15.07.96  Correct sysTempPath method                              Stefc
       21.07.96  New functions strContains & strContainsU                Stefc
       28.07.96  comIsCServe also check for xxx@compuServe.com           Stefc
       31.07.96  added strCapitalize after idea from Fred N. Read        Stefc
       04.08.96  strByteSize() now can also display Bytes                Stefc
       05.08.96  added regWriteShellExt()                                Stefc
       06.08.96  added sysColorDepth()                                   Stefc
       07.08.96  added strSoundex()                                      Stefc
    }
    unit xProcs;

    interface

    uses
     {$IFDEF Win32} Windows, Registry, ShellAPI, {$ELSE} WinTypes, WinProcs, {$ENDIF}
      Messages, Classes, Graphics;

    type
      Float = Extended;    { our type for float arithmetic }

     {$IFDEF Win32}        { our type for integer functions, Int_ is ever 32 bit }
      Int_  = Integer;
     {$ELSE}
      Int_  = Longint;
     {$ENDIF}

    const
      XCOMPANY        = 'Fabula Software';

    const
      { several important ASCII codes }
      NULL            =  #0;
      BACKSPACE       =  #8;
      TAB             =  #9;
      LF              = #10;
      CR              = #13;
      EOF_            = #26;    { 30.07.96 sb }
      ESC             = #27;
      BLANK           = #32;
      SPACE           = BLANK;

      { digits as chars }
      ZERO   = '0';  ONE  = '1';  TWO    = '2';  THREE  = '3';  FOUR  = '4';
      FIVE   = '5';  SIX  = '6';  SEVEN  = '7';  EIGHT  = '8';  NINE  = '9';

      { special codes }
      SLASH           = '\';     { used in filenames }
      HEX_PREFIX      = '$';     { prefix for hexnumbers }

      CRLF            : PChar = CR+LF;

      { common computer sizes }
      KBYTE           = Sizeof(Byte) shl 10;
      MBYTE           = KBYTE        shl 10;
      GBYTE           = MBYTE        shl 10;

      { Low floating point value }
      FLTZERO         : Float = 0.00000001;

      DIGITS          : set of Char = [ZERO..NINE];

      { important registry keys / items }
      REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
      REG_CURRENT_USER    = 'RegisteredOwner';
      REG_CURRENT_COMPANY = 'RegisteredOrganization';

      PRIME_16       = 65521;
      PRIME_32       = 2147483647;

      MINSHORTINT    = -128;               { 1.8.96 sb }
      MAXSHORTINT    =  127;
      MINBYTE        =  0;
      MAXBYTE        =  255;
      MINWORD        =  0;
      MAXWORD        =  65535;

    type
      TMonth        = (NoneMonth,January,February,March,April,May,June,July,
                       August,September,October,November,December);

      TDayOfWeek    = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);

      { Online eMail Service Provider }
      TMailProvider = (mpCServe, mpInternet, mpNone);

      TLicCallback  = function ( var Code: Integer): Integer;

      TBit          = 0..31;

      { Search and Replace options }
      TSROption     = (srWord,srCase,srAll);
      TSROptions    = set of TsrOption;

    var
      IsWin95,
      IsWinNT   : Boolean;
      IsFabula  : TLicCallBack;

      xLanguage : Integer;
      xLangOfs  : Integer;

    { bit manipulating }
    function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
    function bitOn(const Value: Int_; const TheBit: TBit): Int_;
    function bitOff(const Value: Int_; const TheBit: TBit): Int_;
    function bitToggle(const Value: Int_; const TheBit: TBit): Int_;

    { String functions }
    function  strHash(const S: String; LastBucket: Integer): Integer;
    function  strCut(const S: String; Len: Integer): String;
    function  strTrim(const S: String): String;
    function  strTrimA(const S: String): String;
    function  strTrimChA(const S: String; C: Char): String;
    function  strTrimChL(const S: String; C: Char): String;
    function  strTrimChR(const S: String; C: Char): String;
    function  strLeft(const S: String; Len: Integer): String;
    function  strLower(const S: String): String;
    function  strMake(C: Char; Len: Integer): String;
    function  strPadChL(const S: String; C: Char; Len: Integer): String;
    function  strPadChR(const S: String; C: Char; Len: Integer): String;
    function  strPadChC(const S: String; C: Char; Len: Integer): String;
    function  strPadL(const S: String; Len: Integer): String;
    function  strPadR(const S: String; Len: Integer): String;
    function  strPadC(const S: String; Len: Integer): String;
    function  strPadZeroL(const S: String; Len: Integer): String;
    procedure strChange(var S:String; const Source, Dest: String);
    function  strRight(const S: String; Len: Integer): String;
    function  strAddSlash(const S: String): String;
    function  strDelSlash(const S: String): String;
    function  strSpace(Len: Integer): String;
    function  strToken(var S: String; Seperator: Char): String;
    function  strTokenCount(S: String; Seperator: Char): Integer;
    function  strTokenAt(const S:String; Seperator: Char; At: Integer): String;
    function  strUpper(const S: String): String;
    function  strOemAnsi(const S:String): String;
    function  strAnsiOem(const S:String): String;
    function  strEqual(const S1,S2: String): Boolean;
    function  strComp(const S1,S2: String): Boolean;
    function  strCompU(const S1,S2: String): Boolean;
    function  strContains(const S1,S2: String): Boolean;
    function  strContainsU(const S1,S2: String): Boolean;
    function  strNiceNum(const S: String): String;
    function  strNiceDateDefault(const S, Default: String): String;
    function  strNiceDate(const S: String): String;
    function  strNiceTime(const S: String): String;
    function  strNicePhone(const S: String): String;
    function  strReplace(const S: String; C: Char; const Replace: String): String;
    function  strCmdLine: String;
    function  strEncrypt(const S: String; Key: Word): String;
    function  strDecrypt(const S: String; Key: Word): String;
    function  strLastCh(const S: String): Char;
    procedure strStripLast(var S: String);
    function  strByteSize(Value: Longint): String;
    function  strSoundex(S: String): String;
    procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
    function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
    function  strCapitalize(const S: String): String;  { 31.07.96 sb }

    {$IFDEF Win32}
    procedure strDebug(const S: String);
    function  strFileLoad(const aFile: String): String;
    procedure strFileSave(const aFile,aString: String);
    {$ENDIF}

    { Integer functions }
    function  intCenter(a,b: Int_): Int_;
    function  intMax(a,b: Int_): Int_;
    function  intMin(a,b: Int_): Int_;
    function  intPow(Base,Expo: Integer): Int_;
    function  intPow10(Exponent: Integer): Int_;
    function  intSign(a: Int_): Integer;
    function  intZero(a: Int_; Len: Integer): String;
    function  intPrime(Value: Integer): Boolean;
    function  intPercent(a, b: Int_): Int_;

    { Floatingpoint functions }
    function  fltAdd(P1,P2: Float; Decimals: Integer): Float;
    function  fltDiv(P1,P2: Float; Decimals: Integer): Float;
    function  fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
    function  fltEqualZero(P: Float): Boolean;
    function  fltGreaterZero(P: Float): Boolean;
    function  fltLessZero(P: Float): Boolean;
    function  fltNeg(P: Float; Negate: Boolean): Float;
    function  fltMul(P1,P2: Float; Decimals: Integer): Float;
    function  fltRound(P: Float; Decimals: Integer): Float;
    function  fltSub(P1,P2: Float; Decimals: Integer): Float;
    function  fltUnEqualZero(P: Float): Boolean;
    function  fltCalc(const Expr: String): Float;
    function  fltPower(a,n: Float): Float;

    { Rectangle functions from Golden Software }
    function  rectHeight(const R: TRect): Integer;
    function  rectWidth(const R: TRect): Integer;
    procedure rectGrow(var R: TRect; Delta: Integer);
    procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
    procedure rectMoveTo(var R: TRect; X, Y: Integer);
    function  rectSet(Left, Top, Right, Bottom: Integer): TRect;
    function  rectInclude(const R1, R2: TRect): Boolean;
    function  rectPoint(const R: TRect; P: TPoint): Boolean;
    function  rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
    function  rectIntersection(const R1, R2: TRect): TRect;
    function  rectIsIntersection(const R1, R2: TRect): Boolean;
    function  rectIsValid(const R: TRect): Boolean;
    function  rectsAreValid(const Arr: array of TRect): Boolean;
    function  rectNull: TRect;
    function  rectIsNull(const R: TRect): Boolean;
    function  rectIsSquare(const R: TRect): Boolean;
    function  rectCentralPoint(const R: TRect): TPoint;
    function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;

    { date functions }
    function  dateYear(D: TDateTime): Integer;
    function  dateMonth(D: TDateTime): Integer;
    function  dateDay(D: TDateTime): Integer;
    function  dateBeginOfYear(D: TDateTime): TDateTime;
    function  dateEndOfYear(D: TDateTime): TDateTime;
    function  dateBeginOfMonth(D: TDateTime): TDateTime;
    function  dateEndOfMonth(D: TDateTime): TDateTime;
    function  dateWeekOfYear(D: TDateTime): Integer;
    function  dateDayOfYear(D: TDateTime): Integer;
    function  dateDayOfWeek(D: TDateTime): TDayOfWeek;
    function  dateLeapYear(D: TDateTime): Boolean;
    function  dateBeginOfQuarter(D: TDateTime): TDateTime;
    function  dateEndOfQuarter(D: TDateTime): TDateTime;
    function  dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
    function  dateDaysInMonth(D: TDateTime): Integer;
    function  dateQuicken(D: TDateTime; Key: Char): TDateTime;

    { time functions }
    function  timeHour(T: TDateTime): Integer;
    function  timeMin(T: TDateTime): Integer;
    function  timeSec(T: TDateTime): Integer;
    function  timeToInt(T: TDateTime): Integer;

    {$IFDEF Win32}
    function  timeZoneOffset: Integer;
    {$ENDIF}

    { com Functions }
    function  comIsCis(const S: String): Boolean;
    function  comIsInt(const S: String): Boolean;
    function  comCisToInt(const S: String): String;
    function  comIntToCis(const S: String): String;
    function  comFaxToCis(const S: String): String;
    function  comNormFax(const Name,Fax: String): String;
    function  comNormPhone(const Phone: String): String;
    function  comNormInt(const Name,Int: String): String;
    function  comNormCis(const Name,Cis: String): String;

    { file functions }
    procedure fileShredder(const Filename: String);
    function  fileSize(const Filename: String): Longint;
    function  fileWildcard(const Filename: String): Boolean;

    {$IFDEF Win32}
    function  fileTemp(const aExt: String): String;
    function  fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
    function  fileLongName(const aFile: String): String;
    function  fileShortName(const aFile: String): String;
    function  fileShellOpen(const aFile: String): Boolean;
    function  fileShellPrint(const aFile: String): Boolean;
    {$ENDIF}
    function  ExtractName(const Filename: String): String;

    { system functions }
    function  sysTempPath:String;
    procedure sysDelay(aMs: Longint);
    procedure sysBeep;
    function  sysColorDepth: Integer;    { 06.08.96 sb }

    {$IFDEF Win32}
    procedure sysSaverRunning(Active: Boolean);
    {$ENDIF}

    { registry functions }

    {$IFDEF Win32}
    function  regReadString(aKey: hKey; const Path: String): String;
    procedure regWriteString(aKey: hKey; const Path,Value: String);
    function  regInfoString(const Value: String): String;
    function  regCurrentUser: String;
    function  regCurrentCompany: String;
    procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
    {$ENDIF}

    { several functions }
    function  Question(const Msg: String):Boolean;
    procedure Information(const Msg: String);
    function  Confirmation(const Msg: String): Word;

    type
      { TRect that can be used persistent as property for components }
      TUnitConvertEvent = function (Sender: TObject;
        Value: Integer; Get: Boolean): Integer of object;

      TPersistentRect = class(TPersistent)
      private
        FRect      : TRect;
        FOnConvert : TUnitConvertEvent;
        procedure SetLeft(Value: Integer);
        procedure SetTop(Value: Integer);
        procedure SetHeight(Value: Integer);
        procedure SetWidth(Value: Integer);
        function  GetLeft: Integer;
        function  GetTop: Integer;
        function  GetHeight: Integer;
        function  GetWidth: Integer;
      public
        constructor Create;
        procedure Assign(Source: TPersistent); override;
        property Rect: TRect read FRect;
        property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
      published
        property Left  : Integer read GetLeft   write SetLeft;
        property Top   : Integer read GetTop    write SetTop;
        property Height: Integer read GetHeight write SetHeight;
        property Width : Integer read GetWidth  write SetWidth;
      end;

    {$IFDEF Win32}
      { Persistent access of components from the registry }
      TPersistentRegistry = class(TRegistry)
      public
        function  ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
        procedure WriteComponent(const Name: String; Component: TComponent);
      end;
    {$ENDIF

      { easy access of the system metrics }
      TSystemMetric = class
      private
        FColorDepth,
        FMenuHeight,
        FCaptionHeight : Integer;
        FBorder,
        FFrame,
        FDlgFrame,
        FBitmap,
        FHScroll,
        FVScroll,
        FThumb,
        FFullScreen,
        FMin,
        FMinTrack,
        FCursor,
        FIcon,
        FDoubleClick,
        FIconSpacing : TPoint;
      protected
        constructor Create;
        procedure Update;
      public
        property MenuHeight: Integer read FMenuHeight;
        property CaptionHeight: Integer read FCaptionHeight;
        property Border: TPoint read FBorder;
        property Frame: TPoint read FFrame;
        property DlgFrame: TPoint read FDlgFrame;
        property Bitmap: TPoint read FBitmap;
        property HScroll: TPoint read FHScroll;
        property VScroll: TPoint read FVScroll;
        property Thumb: TPoint read FThumb;
        property FullScreen: TPoint read FFullScreen;
        property Min: TPoint read FMin;
        property MinTrack: TPoint read FMinTrack;
        property Cursor: TPoint read FCursor;
        property Icon: TPoint read FIcon;
        property DoubleClick: TPoint read FDoubleClick;
        property IconSpacing: TPoint read FIconSpacing;
        property ColorDepth: Integer read FColorDepth;
      end;

    var
      SysMetric: TSystemMetric;

    type
      TDesktopCanvas = class(TCanvas)
      private
        DC           : hDC;
      public
        constructor  Create;
        destructor   Destroy; override;
      end;

    implementation

    uses
      SysUtils, Controls, Forms, Consts, Dialogs;

    { bit manipulating }
    function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
    begin
      Result:= (Value and (1 shl TheBit)) <> 0;
    end;

    function bitOn(const Value: Int_; const TheBit: TBit): Int_;
    begin
      Result := Value or (1 shl TheBit);
    end;

    function bitOff(const Value: Int_; const TheBit: TBit): Int_;
    begin
      Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
    end;

    function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
    begin
      result := Value xor (1 shl TheBit);
    end;

    { string methods }

    function strHash(const S: String; LastBucket: Integer): Integer;
    var
      i: Integer;
    begin
      Result:=0;
      for i := 1 to Length(S) do
        Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
    end;

    function strTrim(const S: String): String;
    begin
      Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
    end;

    function strTrimA(const S: String): String;
    begin
      Result:=StrTrimChA(S,BLANK);
    end;

    function strTrimChA(const S: String; C: Char): String;
    var
      I               : Word;
    begin
      Result:=S;
      for I:=Length(Result) downto 1 do
        if Result[I]=C then Delete(Result,I,1);
    end;

    function strTrimChL(const S: String; C: Char): String;
    begin
      Result:=S;
      while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
    end;

    function strTrimChR(const S: String; C: Char): String;
    begin
      Result:=S;
      while (Length(Result)> 0) and (Result[Length(Result)]=C) do
        Delete(Result,Length(Result),1);
    end;

    function strLeft(const S: String; Len: Integer): String;
    begin
      Result:=Copy(S,1,Len);
    end;

    function strLower(const S: String): String;
    begin
      Result:=AnsiLowerCase(S);
    end;

    function strMake(C: Char; Len: Integer): String;
    begin
      Result:=strPadChL('',C,Len);
    end;

    function strPadChL(const S: String; C: Char; Len: Integer): String;
    begin
      Result:=S;
      while Length(Result)<Len do Result:=C+Result;
    end;

    function strPadChR(const S: String; C: Char; Len: Integer): String;
    begin
      Result:=S;
      while Length(Result)<Len do Result:=Result+C;
    end;

    function strPadChC(const S: String; C: Char; Len: Integer): String;
    begin
      Result:=S;
      while Length(Result)<Len do
      begin
        Result:=Result+C;
        if Length(Result)<Len then Result:=C+Result;
      end;
    end;

    function strPadL(const S: String; Len: Integer): String;
    begin
      Result:=strPadChL(S,BLANK,Len);
    end;

    function strPadC(const S: String; Len: Integer): String;
    begin
      Result:=strPadChC(S,BLANK,Len);
    end;

    function strPadR(const S: String; Len: Integer): String;
    begin
      Result:=strPadChR(S,BLANK,Len);
    end;

    function strPadZeroL(const S: String; Len: Integer): String;
    begin
      Result:=strPadChL(strTrim(S),ZERO,Len);
    end;

    function strCut(const S: String; Len: Integer): String;
    begin
      Result:=strLeft(strPadR(S,Len),Len);
    end;

    function strRight(const S: String; Len: Integer): String;
    begin
      if Len>=Length(S) then
        Result:=S
      else
        Result:=Copy(S,Succ(Length(S))-Len,Len);
    end;

    function strAddSlash(const S: String): String;
    begin
      Result:=S;
      if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
    end;

    function strDelSlash(const S: String): String;
    begin
      Result:=S;
      if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
    end;

    function strSpace(Len: Integer): String;
    begin
      Result:=StrMake(BLANK,Len);
    end;

    function strToken(var S: String; Seperator: Char): String;
    var
      I               : Word;
    begin
      I:=Pos(Seperator,S);
      if I<>0 then
      begin
        Result:=System.Copy(S,1,I-1);
        System.Delete(S,1,I);
      end else
      begin
        Result:=S;
        S:='';
      end;
    end;

    function strTokenCount(S: String; Seperator: Char): Integer;
    begin
      Result:=0;
      while StrToken(S,Seperator)<>'' do Inc(Result);
    end;

    function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
    var
      j,i: Integer;
    begin
      Result:='';
      j := 1;
      i := 0;
      while (i<=At ) and (j<=Length(S)) do
      begin
        if S[j]=Seperator then
           Inc(i)
        else if i = At then
           Result:=Result+S[j];
        Inc(j);
      end;
    end;

    function strUpper(const S: String): String;
    begin
      Result:=AnsiUpperCase(S);
    end;

    function strOemAnsi(const S:String):String;
    begin
     {$IFDEF Win32}
      SetLength(Result,Length(S));
     {$ELSE}
      Result[0]:=Chr(Length(S));
     {$ENDIF}
      OemToAnsiBuff(@S[1],@Result[1],Length(S));
    end;

    function strAnsiOem(const S:String): String;
    begin
     {$IFDEF Win32}
      SetLength(Result,Length(S));
     {$ELSE}
      Result[0]:=Chr(Length(S));
     {$ENDIF}
      AnsiToOemBuff(@S[1],@Result[1],Length(S));
    end;

    function strEqual(const S1,S2: String): Boolean;
    begin
      Result:=AnsiCompareText(S1,S2)=0;
    end;

    function strCompU(const S1,S2: String) : Boolean;
    begin
      Result:=strEqual(strLeft(S2,Length(S1)),S1);
    end;

    function strComp(const S1,S2: String) : Boolean;
    begin
      Result:=strLeft(S2,Length(S1))=S1;
    end;

    function strContains(const S1,S2: String): Boolean;
    begin
      Result:=Pos(S1,S2) > 0;
    end;

    function strContainsU(const S1,S2: String): Boolean;
    begin
      Result:=strContains(strUpper(S1),strUpper(S2));
    end;

    function strNiceNum(const S: String) : String;
    var
      i    : Integer;
      Seps : set of Char;
    begin
      Seps:=[ThousandSeparator,DecimalSeparator];
      Result:= ZERO;
      for i := 1 to Length(S) do
        if S[i] in DIGITS + Seps then
        begin
          if S[i] = ThousandSeparator then
             Result:=Result+DecimalSeparator
          else
             Result:=Result+S[i];
          if S[i] In Seps then Seps:=[];
        end
    end;

    function strNiceDate(const S: String): String;
    begin
      Result:=strNiceDateDefault(S, DateToStr(Date));
    end;

    function  strNiceDateDefault(const S, Default: String): String;
    (* sinn der Procedure:
       Irgendeinen String übergeben und in ein leidlich brauchbares Datum verwandeln.
       Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
       eingabe 10 = Rückgabe 10 des Laufenden Monats
       eingabe 10.12 = Rückgabe des 10.12. des laufenden Jahres.
       eingabe 10.12.96 = Rückgabe des Strings
       eingabe 10,12,96 = Rückgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
       Eine Plausbilitätskontrolle des Datums findet nicht Statt.
       Geplante Erweiterung:
       eingabe: +14  = Rückgabe 14 Tage Weiter
       eingabe: +3m  = Rückgabe 3 Monate ab Heute
       eingabe: +3w  = Rückgabe 3 Wochen (3*7 Tage) ab Heute
       Das gleiche auch Rückwärts mit  Minuszeichen
       eingabe: e oder E oder f  = Nächster Erster
       eingabe: e+1m Erster des übernächsten Monats
       Da läßt sich aber noch trefflich weiterspinnen

       EV. mit Quelle rausgeben, damit sich die Engländer und Franzosen an
       Ihren Datumsformaten selbst erfreuen können und wir die passenden umsetzungen
       bekommen. *)
    var
      a        : array [0..2] of string[4];
      heute    : string;
      i,j      : integer;
    begin
      a[0]:='';
      a[1]:='';
      a[2]:='';
      heute := Default;

      j := 0;
      for i := 0 to length(S) do
        if S[i] in DIGITS then
          a[j] := a[j]+S[i]
        else if S[i] in [DateSeparator] then Inc(j);
      for i := 0 to 2 do
      if Length(a[i]) = 0 then
        if I=2 then
          a[i] :=copy(heute,i*3+1,4)
        else
          a[i] := copy(heute,i*3+1,2)
      else
        if length(a[i]) = 1 then
          a[i] := '0'+a[i];

      Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
      try
        StrToDate(Result);
      except
        Result:=DateToStr(Date);
      end;
    end;

    function strNiceTime(const S: String): String;
    var
      a   : array[0..2] of string[2];
      i,j : integer;
    begin
      j:= 0;
      a[0]:= '';
      a[1]:='';
      a[2]:='';
      for i:= 1 to length(S) do
      begin
        if S[i] in DIGITS then
        begin
          a[j] := a[j]+S[i];
        end
        else if S[i] in ['.',',',':'] then
          inc(J);
        if j > 2 then exit;
      end;
      for J := 0 to 2 do
        if length(a[j]) = 1 then a[j] := '0'+a[j] else
        if length(a[j]) = 0 then a[j] := '00';
      Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
    end;

    function strNicePhone(const S: String): String;
    var
      L : Integer;
    begin
      if Length(S) > 3 then
      begin
        L:=(Length(S)+1) div 2;
        Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
      end else
        Result := S;
    end;

    function strReplace(const S: String; C: Char; const Replace: String): String;
    var
      i : Integer;
    begin
      Result:='';
      for i:=Length(S) downto 1 do
        if S[i]=C then Result:=Replace+Result
                  else Result:=S[i]+Result;
    end;

    procedure strChange(var S:String; const Source, Dest: String);
    var
      P : Integer;
    begin
      P:=Pos(Source,S);
      while P<>0 do
      begin
        Delete(S,P,Length(Source));
        Insert(Dest,S,P);
        P:=Pos(Source,S);
      end;
    end;

    function strCmdLine: String;
    var
      i: Integer;
    begin
      Result:='';
      for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
      Delete(Result,Length(Result),1);
    end;

    { sends a string to debug windows inside the IDE }
    {$IFDEF Win32}
    procedure strDebug(const S: String);
    var
      P    : PChar;
      CPS  : TCopyDataStruct;
      aWnd : hWnd;
    begin
      aWnd := FindWindow('TfrmDbgTerm', nil);
      if aWnd <> 0 then
      begin
        CPS.cbData := Length(S) + 2;
        GetMem(P, CPS.cbData);
        try
          StrPCopy(P, S+CR);
          CPS.lpData := P;
          SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
        finally
          FreeMem(P, Length(S)+2);
        end;
      end;
    end;
    {$ENDIF}

    function strSoundex(S: String): String;
    const
      CvTable : array['B'..'Z'] of char = (
        '1', '2', '3', '0', '1',   {'B' .. 'F'}
        '2', '0', '0', '2', '2',   {'G' .. 'K'}
        '4', '5', '5', '0', '1',   {'L' .. 'P'}
        '2', '6', '2', '3', '0',   {'Q' .. 'U'}
        '1', '0', '2', '0', '2' ); {'V' .. 'Z'}
    var
      i,j : Integer;
      aGroup,Ch  : Char;

      function Group(Ch: Char): Char;
      begin
        if (Ch in ['B' .. 'Z']) and not (Ch In ['E','H','I','O','U','W','Y']) then
           Result:=CvTable[Ch]
        else
           Result:='0';
      end;

    begin
      Result := '000';
      if S='' then exit;

      S:= strUpper(S);
      i:= 2;
      j:= 1;
      while (i <= Length(S)) and ( j<=3) do
      begin
        Ch := S[i];
        aGroup := Group(Ch);
        if (aGroup <> '0') and (Ch <> S[i-1]) and
           ((J=1) or (aGroup <> Result[j-1])) and
           ((i>2) or (aGroup <> Group(S[1]))) then
        begin
          Result[j] :=aGroup;
          Inc(j);
        end;
        Inc(i);
      end; {while}

      Result:=S[1]+'-'+Result;
    end;

    function strByteSize(Value: Longint): String;

      function FltToStr(F: Extended): String;
      begin
        Result:=FloatToStrF(Round(F),ffNumber,6,0);
      end;

    begin
      if Value > GBYTE then
        Result:=FltTostr(Value / GBYTE)+' GB'
      else if Value > MBYTE then
        Result:=FltToStr(Value / MBYTE)+' MB'
      else if Value > KBYTE then
        Result:=FltTostr(Value / KBYTE)+' KB'
      else
        Result:=FltTostr(Value / KBYTE)+' Byte';   { 04.08.96 sb }
    end;

    const
      C1 = 52845;
      C2 = 22719;

    function strEncrypt(const S: String; Key: Word): String;
    var
      I: Integer;
    begin
     {$IFDEF Win32}
      SetLength(Result,Length(S));
     {$ELSE}
       Result[0]:=Chr(Length(S));
     {$ENDIF}
      for I := 1 to Length(S) do begin
        Result[I] := Char(Ord(S[I]) xor (Key shr 8));
        Key := (Ord(Result[I]) + Key) * C1 + C2;
      end;
    end;

    function strDecrypt(const S: String; Key: Word): String;
    var
      I: Integer;
    begin
     {$IFDEF Win32}
      SetLength(Result,Length(S));
     {$ELSE}
       Result[0]:=Chr(Length(S));
     {$ENDIF}
      for I := 1 to Length(S) do begin
        Result[I] := char(Ord(S[I]) xor (Key shr 8));
        Key := (Ord(S[I]) + Key) * C1 + C2;
      end;
    end;

    function  strLastCh(const S: String): Char;
    begin
      Result:=S[Length(S)];
    end;

    procedure strStripLast(var S: String);
    begin
      if Length(S) > 0 then Delete(S,Length(S),1);
    end;

    procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
    var hs,hs1,hs2,hs3: String;
    var i,j : integer;

    begin
     if  srCase in Options then
      begin
       hs := s;
       hs3 := source;
      end
     else
      begin
       hs:= StrUpper(s);
       hs3 := StrUpper(Source);
      end;
     hs1:= '';
     I:= pos(hs3,hs);
     j := length(hs3);
     while i > 0 do
     begin
       delete(hs,1,i+j-1); {Anfang Rest geändert 8.7.96 KM}
       hs1 := Hs1+copy(s,1,i-1); {Kopieren geändert 8.7.96 KM}
       delete(s,1,i-1); {Löschen bis Anfang posgeändert 8.7.96 KM}
       hs2 := copy(s,1,j); {Bis ende pos Sichern}
       delete(s,1,j); {Löschen bis ende Pos}
       if    (not (srWord in Options))
           or (pos(s[1],' .,:;-#''+*?=)(/&%$§"!{[]}\~<>|') > 0) then
        begin
         {Quelle durch ziel erstzen}
         hs1 := hs1+dest;
        end
       else
        begin
         hs1 := hs1+hs2;
        end;
       if srall in options then
        I:= pos(hs3,hs)
       else
        i :=0;
      end;
      s:= hs1+s;
    end;

    function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
    var
      aTmp: array[0..255] of Char;
    begin
     {$IFDEF Win32}
       GetPrivateProfileString(PChar(aSection), PChar(aEntry),
          PChar(aDefault), aTmp, Sizeof(aTmp)-1, PChar(aFile));
       Result:=StrPas(aTmp);
     {$ENDIF}
    end;

    function strCapitalize(const S: String): String;  { 31.07.96 sb }
    var
      i      : Integer;
      Ch     : Char;
      First  : Boolean;
    begin
      First  := True;
      Result := '';
      for i:=1 to Length(S) do
      begin
        Ch:=S[i];
        if Ch in [SPACE,'-','.'] then
           First:=True
        else if First then
        begin
          Ch:=strUpper(Ch)[1];
          First:=False;
        end;
        Result:=Result+Ch;
      end;
    end;

    {$IFDEF Win32}
    function strFileLoad(const aFile: String): String;
    var
      aStr : TStrings;
    begin
      Result:='';
      aStr:=TStringList.Create;
      try
        aStr.LoadFromFile(aFile);
        Result:=aStr.Text;
      finally
        aStr.Free;
      end;
    end;

    procedure strFileSave(const aFile,aString: String);
    var
      Stream: TStream;
    begin
      Stream := TFileStream.Create(aFile, fmCreate);
      try
        Stream.WriteBuffer(Pointer(aString)^,Length(aString));
      finally
        Stream.Free;
      end;
    end;
    {$ENDIF}

    { Integer stuff }

    function IntCenter(a,b: Int_): Int_;
    begin
      Result:=a div 2 - b div 2;
    end;

    function IntMax(a,b: Int_): Int_;
    begin
      if a>b then Result:=a else Result:=b;
    end;

    function IntMin(a,b: Int_): Int_;
    begin
      if a<b then Result:=a else Result:=b;
    end;

    function IntPow(Base,Expo: Integer): Int_;
    var
      Loop             : Word;
    begin
      Result:=1;
      for Loop:=1 to Expo do Result:=Result*Base;
    end;

    function IntPow10(Exponent: Integer): Int_;
    begin
      Result:=IntPow(10,Exponent);
    end;

    function IntSign(a: Int_): Integer;
    begin
      if a<0 then Result:=-1 else if a>0 then Result:=+1 else Result:= 0;
    end;

    function IntZero(a: Int_; Len: Integer): String;
    begin
      Result:=strPadZeroL(IntToStr(a),Len);
    end;

    function IntPrime(Value: Integer): Boolean;
    var
      i : integer;
    begin
      Result:=False;
      if Value mod 2 <> 0 then
      begin
        i := 1;
        repeat
          i := i + 2;
          Result:= Value mod i = 0
        until Result or ( i > Trunc(sqrt(Value)) );
        Result:= not Result;
      end;
    end;

    function IntPercent(a, b : Int_): Int_;
    begin
      Result := Trunc((a / b)*100);
    end;

    { Floating point stuff }

    function FltAdd(P1,P2: Float; Decimals: Integer): Float;
    begin
      P1    :=fltRound(P1,Decimals);
      P2    :=fltRound(P2,Decimals);
      Result:=fltRound(P1+P2,Decimals);
    end;

    function FltDiv(P1,P2: Float; Decimals: Integer): Float;
    begin
      P1:=fltRound(P1,Decimals);
      P2:=fltRound(P2,Decimals);
      if P2=0.0 then P2:=FLTZERO;       { provide division by zero }
      Result:=fltRound(P1/P2,Decimals);
    end;

    function FltEqual(P1,P2: Float; Decimals: Integer): Boolean;
    var
      Diff            : Float;
    begin
      Diff:=fltSub(P1,P2,Decimals);
      Result:=fltEqualZero(Diff);
    end;

    function FltEqualZero(P: Float): Boolean;
    begin
      Result:=(P>-FLTZERO) and (P<FLTZERO);
    end;

    function FltGreaterZero(P: Float): Boolean;
    begin
      Result:=P>FLTZERO;
    end;

    function FltLessZero(P: Float): Boolean;
    begin
      Result:=P<-FLTZERO;
    end;

    function FltNeg(P: Float; Negate: Boolean): Float;
    begin
      if Negate then Result:=-P else Result:=P;
    end;

    function FltMul(P1,P2: Float; Decimals: Integer): Float;
    begin
      P1    :=fltRound(P1,Decimals);
      P2    :=fltRound(P2,Decimals);
      Result:=fltRound(P1*P2,Decimals);
    end;

    function FltRound(P: Float; Decimals: Integer): Float;
    var
      Factor  : LongInt;
      Help    : Float;
    begin
      Factor:=IntPow10(Decimals);
      if P<0 then Help:=-0.5 else Help:=0.5;
      Result:=Int(P*Factor+Help)/Factor;
      if fltEqualZero(Result) then Result:=0.00;
    end;

    function FltSub(P1,P2: Float; Decimals: Integer): Float;
    begin
      P1    :=fltRound(P1,Decimals);
      P2    :=fltRound(P2,Decimals);
      Result:=fltRound(P1-P2,Decimals);
    end;

    function FltUnEqualZero(P: Float): Boolean;
    begin
      Result:=(P<-FLTZERO) or (P>FLTZERO)
    end;

    function FltCalc(const Expr: String): Float;
    const
      STACKSIZE = 10;
    var
      Stack   : array[0..STACKSIZE] of double;
      oStack  : array[0..STACKSIZE] of char;
      z,n     : double;
      i,j,m   : integer;
      Bracket : boolean;
    begin
      Bracket:= False; j := 0; n:= 1;z:=0; m:=1;
      for i := 1 to Length(Expr) do
      begin
        if not Bracket  then
           case Expr[i] of
             '0' .. '9': begin
                           z:=z*10+ord(Expr[i])-ord('0');
                           n:=n*m;
                         end;
             ',',#46   : m := 10;
             '('       : Bracket := True; {hier Klammeranfang merken, Zähler!!}
             '*','x',
             'X',
             '/','+'   : begin
                           Stack[j] := z/n;
                           oStack[j] := Expr[i];
                           Inc(j);
                           m:=1;z:=0;n:=1;
                         end;
           end {case}
        else
           Bracket:= Expr[i]<> ')'; {hier Rekursiver Aufruf, Zähler !!};
      end;
      Stack[j] := z/n;
      for i := 1 to j do
        case oStack[i-1] of
          '*','x','X' :  Stack[i]:= Stack[i-1]*Stack[i];
          '/'         :  Stack[i]:= Stack[i-1]/Stack[i];
          '+'         :  Stack[i]:= Stack[i-1]+Stack[i];
        end;
      Result:= Stack[j];
    end;

    function fltPower(a, n: Float): Float;
    begin
      Result:=Exp(n * Ln(a));
    end;

    { Rectangle Calculations }

    function RectHeight(const R: TRect): Integer;
    begin
      Result := R.Bottom - R.Top;
    end;

    function RectWidth(const R: TRect): Integer;
    begin
      Result := R.Right - R.Left;
    end;

    procedure RectGrow(var R: TRect; Delta: Integer);
    begin
      with R do
      begin
        Dec(Left, Delta);
        Dec(Top, Delta);
        Inc(Right, Delta);
        Inc(Bottom, Delta);
      end;
    end;

    procedure RectRelativeMove(var R: TRect; DX, DY: Integer);
    begin
      with R do
      begin
        Inc(Left, DX);
        Inc(Right, DX);
        Inc(Top, DY);
        Inc(Bottom, DY);
      end;
    end;

    procedure RectMoveTo(var R: TRect; X, Y: Integer);
    begin
      with R do
      begin
        Right := X + Right - Left;
        Bottom := Y + Bottom - Top;
        Left := X;
        Top := Y;
      end;
    end;

    function RectSet(Left, Top, Right, Bottom: Integer): TRect;
    begin
      Result.Left := Left;
      Result.Top := Top;
      Result.Right := Right;
      Result.Bottom := Bottom;
    end;

    function RectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
    begin
      Result.TopLeft := TopLeft;
      Result.BottomRight := BottomRight;
    end;

    function RectInclude(const R1, R2: TRect): Boolean;
    begin
      Result := (R1.Left >= R2.Left) and (R1.Top >= R2.Top)
        and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom);
    end;

    function  RectPoint(const R: TRect; P: TPoint): Boolean;
    begin
      Result := (p.x>r.left) and (p.x<r.right) and (p.y>r.top) and (p.y<r.bottom);
    end;

    function RectIntersection(const R1, R2: TRect): TRect;
    begin
      with Result do
      begin
        Left := intMax(R1.Left, R2.Left);
        Top := intMax(R1.Top, R2.Top);
        Right := intMin(R1.Right, R2.Right);
        Bottom := intMin(R1.Bottom, R2.Bottom);
      end;

      if not RectIsValid(Result) then
        Result := RectSet(0, 0, 0, 0);
    end;

    function RectIsIntersection(const R1, R2: TRect): Boolean;
    begin
      Result := not RectIsNull(RectIntersection(R1, R2));
    end;

    function RectIsValid(const R: TRect): Boolean;
    begin
      with R do
        Result := (Left <= Right) and (Top <= Bottom);
    end;

    function RectsAreValid(const Arr: array of TRect): Boolean;
    var
      I: Integer;
    begin
      for I := Low(Arr) to High(Arr) do
        if not RectIsValid(Arr[I]) then
        begin
          Result := False;
          exit;
        end;
      Result := True;
    end;

    function RectNull: TRect;
    begin
      Result := RectSet(0, 0, 0, 0);
    end;

    function RectIsNull(const R: TRect): Boolean;
    begin
      with R do
        Result := (Left = 0) and (Right = 0) and (Top = 0) and (Bottom = 0);
    end;

    function RectIsSquare(const R: TRect): Boolean;
    begin
      Result := RectHeight(R) = RectWidth(R);
    end;

    function RectCentralPoint(const R: TRect): TPoint;
    begin
      Result.X := R.Left + (RectWidth(R) div 2);
      Result.Y := R.Top + (RectHeight(R) div 2);
    end;

    function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
    begin
      Result:=rectSet(aLeft,aTop,aLeft+aWidth,aTop+aHeight);
    end;

    { file functions }

    procedure fileShredder(const Filename: String);
    var
      aFile : Integer;
      aSize : Integer;
      P     : Pointer;
    begin
      aSize:=fileSize(Filename);
      aFile:=FileOpen(FileName,fmOpenReadWrite);
      try
        Getmem(P,aSize);
        fillchar(P^,aSize,'X');
        FileWrite(aFile,P^,aSize);
        Freemem(P,aSize);
      finally
        FileClose(aFile);
        DeleteFile(Filename);
      end;
    end;

    function fileSize(const FileName: String): LongInt;
    var
      SearchRec       : TSearchRec;
    begin                                       { !Win32! -> GetFileSize }
      if FindFirst(FileName,faAnyFile,SearchRec)=0
        then Result:=SearchRec.Size
        else Result:=0;
    end;

    function fileWildcard(const Filename: String): Boolean;
    begin
      Result:=(Pos('*',Filename)<>0) or (Pos('?',Filename)<>0);
    end;

    {$IFDEF Win32}
    function fileTemp(const aExt: String): String;
    var
      Buffer: array[0..1023] of Char;
      aFile : String;
    begin
      GetTempPath(Sizeof(Buffer)-1,Buffer);
      GetTempFileName(Buffer,'TMP',0,Buffer);
      SetString(aFile, Buffer, StrLen(Buffer));
      Result:=ChangeFileExt(aFile,aExt);
      RenameFile(aFile,Result);
    end;

    function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
    var
      StartupInfo : TStartupInfo;
      ProcessInfo : TProcessInformation;
    begin
      {setup the startup information for the application }
      FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
      with StartupInfo do
      begin
        cb:= SizeOf(TStartupInfo);
        dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
        if aHide then wShowWindow:= SW_HIDE
                 else wShowWindow:= SW_SHOWNORMAL;
      end;

      Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
                   NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
      if aWait then
         if Result then
         begin
           WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
           WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
         end;
    end;

    function fileShellOpen(const aFile: String): Boolean;
    begin
      Result := ShellExecute( Application.Handle,
        'open', PChar(aFile), nil, nil, SW_NORMAL) <= 32;
    end;

    function fileShellPrint(const aFile: String): Boolean;
    begin
      Result := ShellExecute( Application.Handle,
        'print', PChar(aFile), nil, nil, SW_HIDE) <= 32;
    end;

    function  fileLongName(const aFile: String): String;
    var
      aInfo: TSHFileInfo;
    begin
      if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
         Result:=StrPas(aInfo.szDisplayName)
      else
         Result:=aFile;
    end;

    function  fileShortName(const aFile: String): String;
    var
      aTmp: array[0..255] of char;
    begin
      if GetShortPathName(PChar(aFile),aTmp,Sizeof(aTmp)-1)=0 then
         Result:=aFile
      else
         Result:=StrPas(aTmp);
    end;

    {$ENDIF}

    function ExtractName(const Filename: String): String;
    var
      aExt : String;
      aPos : Integer;
    begin
      aExt:=ExtractFileExt(Filename);
      Result:=ExtractFileName(Filename);
      if aExt <> '' then
      begin
        aPos:=Pos(aExt,Result);
        if aPos>0 then
           Delete(Result,aPos,Length(aExt));
      end;
    end;

    { date calculations }

    function  dateYear(D: TDateTime): Integer;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=Year;
    end;

    function  dateMonth(D: TDateTime): Integer;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=Month;
    end;

    function  dateBeginOfYear(D: TDateTime): TDateTime;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=EncodeDate(Year,1,1);
    end;

    function  dateEndOfYear(D: TDateTime): TDateTime;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=EncodeDate(Year,12,31);
    end;

    function  dateBeginOfMonth(D: TDateTime): TDateTime;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=EncodeDate(Year,Month,1);
    end;

    function  dateEndOfMonth(D: TDateTime): TDateTime;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      if Month=12 then
      begin
        Inc(Year);
        Month:=1;
      end else
        Inc(Month);
      Result:=EncodeDate(Year,Month,1)-1;
    end;

    function dateWeekOfYear(D: TDateTime): Integer; { Armin Hanisch }
    const
      t1: array[1..7] of ShortInt = ( -1,  0,  1,  2,  3, -3, -2);
      t2: array[1..7] of ShortInt = ( -4,  2,  1,  0, -1, -2, -3);
    var
      doy1,
      doy2    : Integer;
      NewYear : TDateTime;
    begin
      NewYear:=dateBeginOfYear(D);
      doy1 := dateDayofYear(D) + t1[DayOfWeek(NewYear)];
      doy2 := dateDayofYear(D) + t2[DayOfWeek(D)];
      if doy1 <= 0 then
        Result := dateWeekOfYear(NewYear-1)
      else if (doy2 >= dateDayofYear(dateEndOfYear(NewYear))) then
        Result:= 1
      else
        Result:=(doy1-1) div 7+1;
    end;

    function dateDayOfYear(D: TDateTime): Integer;
    begin
      Result:=Trunc(D-dateBeginOfYear(D))+1;
    end;

    function dateDayOfWeek(D: TDateTime): TDayOfWeek;
    begin
      Result:=TDayOfWeek(Pred(DayOfWeek(D)));
    end;

    function dateLeapYear(D: TDateTime): Boolean;
    var
      Year,Month,Day: Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=(Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
    end;

    function dateBeginOfQuarter(D: TDateTime):TDateTime;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=EncodeDate(Year,((Month-1 div 3) * 3)+1,1);
    end;

    function dateEndOfQuarter(D: TDateTime): TDateTime;
    begin
      Result:=dateBeginOfQuarter(dateBeginOfQuarter(D)+(3*31))-1;
    end;

    function dateBeginOfWeek(D: TDateTime; Weekday: Integer): TDateTime;
    begin
      Result:=D;
      while DayOfWeek(Result)<>Weekday do Result:=Result-1;
    end;

    function dateDaysInMonth(D: TDateTime): Integer;
    const
      DaysPerMonth: array[1..12] of Byte= (31,28,31,30,31,30,31,31,30,31,30,31);
    var
      Month: Integer;
    begin
      Month:=dateMonth(D);
      Result:=DaysPerMonth[Month];
      if (Month=2) and dateLeapYear(D) then Inc(Result);
    end;

    function dateDay(D: TDateTime): Integer;
    var
      Year,Month,Day : Word;
    begin
      DecodeDate(D,Year,Month,Day);
      Result:=Day;
    end;

    function dateQuicken(D: TDateTime; Key: Char): TDateTime;
    const
     {$IFDEF German}
      _ToDay    = 'H';
      _PrevYear = 'J';
      _NextYear = 'R';
      _PrevMonth= 'M';
      _NextMonth= 'T';
     {$ELSE}
      _ToDay    = 'H';      { if someone knows US keys, please tell us }
      _PrevYear = 'J';
      _NextYear = 'R';
      _PrevMonth= 'M';
      _NextMonth= 'T';
     {$ENDIF}

    begin
      case Upcase(Key) of                     { Quicken Date Fast Keys }
        '+'        : Result := D+1;
        '-'        : Result := D-1;
        _ToDay     : Result := Date;
        _PrevYear  : if D <> dateBeginOfYear(D)  then Result:=dateBeginOfYear(D)
                                                 else Result:=dateBeginOfYear(D-1);
        _NextYear  : if D <> dateEndOfYear(D)    then Result:=dateEndOfYear(D)
                                                 else Result:=dateEndOfYear(Date+1);
        _PrevMonth : if D <> dateBeginOfMonth(D) then Result:=dateBeginOfMonth(D)
                                                 else Result:=dateBeginOfMonth(D-1);
        _NextMonth : if D <> dateEndOfMonth(D)   then Result:=dateEndOfMonth(D)
                                                 else Result:=dateEndOfMonth(D+1);
        else Result := D;
      end;
    end;

    { time functions }

    function  timeHour(T: TDateTime): Integer;
    var
      Hour,Minute,Sec,Sec100: Word;
    begin
      DecodeTime(T,Hour,Minute,Sec,Sec100);
      Result:=Hour;
    end;

    function  timeMin(T: TDateTime): Integer;
    var
      Hour,Minute,Sec,Sec100: Word;
    begin
      DecodeTime(T,Hour,Minute,Sec,Sec100);
      Result:=Minute;
    end;

    function  timeSec(T: TDateTime): Integer;
    var
      Hour,Minute,Sec,Sec100: Word;
    begin
      DecodeTime(T,Hour,Minute,Sec,Sec100);
      Result:=Sec;
    end;

    function  timeToInt(T: TDateTime): Integer;
    begin
      Result:=Trunc((MSecsPerday * T) / 1000);
    end;

    {$IFDEF Win32}
    function  timeZoneOffset: Integer;
    var
      aTimeZoneInfo : TTimeZoneInformation;
    begin
      if GetTimeZoneInformation(aTimeZoneInfo)<>-1 then
         Result := aTimeZoneInfo.Bias
      else
         Result := 0;
    end;
    {$ENDIF}

    { Communications Functions }

    function  comIsCis(const S: String): Boolean;
    var
      aSt: String;
      PreId,
      PostId: Integer;
    begin
      Result:=strContainsU('@compuserve.com',S);     { 28.7.96 sb This is also on CIS }
      if not Result then
         if Pos(',',S) > 0 then
         try
           aSt:=S;
           PreId:=StrToInt(strToken(aSt,','));
           PostId:=StrToInt(aSt);
           Result:=(PreId > 0) and (PostId > 0);
         except
           Result:=False;
         end;
    end;

    function  comIsInt(const S: String): Boolean;
    var
      aSt : String;
      PreId,
      PostId : String;
    begin
      try
        aSt:=S;
        PreId:=strToken(aSt,'@');
        PostId:=aSt;
        Result:=(Length(PreId)>0) and (Length(PostId)>0);
      except
        Result:=False;
      end;
    end;

    { converts a CIS adress to a correct Internet adress }
    function  comCisToInt(const S: String): String;
    var
      P : Integer;
    begin
      p:=Pos('INTERNET:',S);
      if P=1 then
        Result:=Copy(S,P+1,Length(S))
      else
      begin
        Result:=S;
        P:=Pos(',',Result);
        if P>0 then Result[P]:='.';
        Result:=Result+'@compuserve.com';     { 22.07.96 sb  Error }
      end;
    end;

    { converts a internet adress to a correct CServe adress }
    function  comIntToCis(const S: String): String;
    var
      P : Integer;
    begin
      p:=Pos('@COMPUSERVE.COM',strUpper(S));
      if p > 0 then
      begin
        Result:=strLeft(S,P-1);
        P:=Pos('.',Result);
        if P>0 then Result[P]:=',';
      end else
        Result:='INTERNET:'+S;
    end;

    { converts a fax adress to a correct CServe adress }
    function  comFaxToCis(const S: String): String;
    begin
      Result:='FAX:'+S;
    end;

    function comNormFax(const Name, Fax: String): String;
    begin
      if Name<>'' then
         Result:=Name+'[fax: '+Name+'@'+strTrim(Fax)+']'
      else
         Result:='[fax: '+strTrim(Fax)+']';
    end;

    function  comNormInt(const Name,Int: String): String;
    begin
      Result:='';
      if comIsInt(Int) then
         if Name <> '' then
            Result := Name + '|smtp: ' + strTrim(Int)
         else
            Result := 'smtp: ' + strTrim(Int);
    end;

    function  comNormCis(const Name,Cis: String): String;
    begin
      Result:='';
      if Name <> '' then
         Result := Name + '[compuserve: ' + strTrim(Cis) + ']'
      else
         Result := '[compuserve: ' + strTrim(Cis) + ']';
    end;

    function  comNormPhone(const Phone: String): String;

      function strValueAt(const S:String; At: Integer): String;
      const
        Seperator = ',';
        Str = '"';
      var
        j,i: Integer;
        FSkip : Boolean;
      begin
        Result:='';
        j := 1;
        i := 0;
        FSkip:= False;
        while (i<=At ) and (j<=Length(S)) do
        begin
          if (S[j]=Str) then
             FSkip:=not FSkip
          else if (S[j]=Seperator) and not FSkip then
             Inc(i)
          else if i = At then
             Result:=Result+S[j];
          Inc(j);
        end;
      end;

    var
      aNumber,
      aCountry,
      aPrefix,
      aDefault,
      aLocation  : String;

      i          : Integer;
    begin
      aDefault  := '1,"Hamburg","","","40",49,0,0,0,"",1," "';
      aLocation := strProfile('telephon.ini','Locations','CurrentLocation','');
      if aLocation <> '' then
      begin
        aLocation:=strTokenAt(aLocation,',',0);
        if aLocation <> '' then
        begin
          aLocation:=strProfile('telephon.ini','Locations','Location'+aLocation,'');
          if aLocation <> '' then
             aDefault := aLocation;
        end;
      end;

      Result:='';
      aNumber:=strTrim(Phone);
      if aNumber <> '' then
        for i:=Length(aNumber) downto 1 do
          if not (aNumber[i] in DIGITS) then
          begin
            if aNumber[i] <> '+' then aNumber[i] := '-';
            if i < Length(aNumber) then                    { remove duplicate digits }
               if aNumber[i]=aNumber[i+1] then
                  Delete(aNumber,i,1);
          end;

      if aNumber <> '' then
      begin
        if aNumber[1] = '+' then
           aCountry := strToken(aNumber,'-')
        else
           aCountry := '+'+strValueAt(aDefault,5);

        aNumber:=strTrimChL(aNumber,'-');

        if aNumber <> '' then
        begin
          if strTokenCount(aNumber,'-') > 1 then
             aPrefix := strTrimChL(strToken(aNumber,'-'),'0')
          else
             aPrefix := strValueAt(aDefault,4);

          aNumber:= strNicePhone(strTrimChA(aNumber,'-'));
          Result := aCountry + ' ('+aPrefix+') '+aNumber;
        end;
      end;
    end;

    { system functions }

    {$IFDEF Win32}
    function sysTempPath: String;
    var
      Buffer: array[0..1023] of Char;
    begin
      SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
    end;
    {$ELSE}
    function sysTempPath:String;
    var
      Buffer: array[0..255] of char;
    begin
      GetTempFileName(#0,'TMP',0,Buffer);             { 15.07.96 sb }
      Result:=StrPas(Buffer);
      DeleteFile(Result);
      Result:=ExtractFilePath(Result);
    end;
    {$ENDIF}

    procedure sysDelay(aMs: Longint);
    var
      TickCount       : LongInt;
    begin
      TickCount:=GetTickCount;
      while GetTickCount - TickCount < aMs do Application.ProcessMessages;
    end;

    procedure sysBeep;
    begin
      messageBeep($FFFF);
    end;

    function sysColorDepth: Integer;
    var
      aDC: hDC;
    begin
      Result:=0;
      try
        aDC := GetDC(0);
        Result:=1 shl (GetDeviceCaps(aDC,PLANES) * GetDeviceCaps(aDC, BITSPIXEL));
      finally
        ReleaseDC(0,aDC);
      end;
    end;

    {$IFDEF Win32}
    procedure sysSaverRunning(Active: Boolean);
    var
      aParam: Longint;
    begin
      SystemParametersInfo (SPI_SCREENSAVERRUNNING, Word(Active),@aParam,0);
    end;
    {$ENDIF}

    { registry functions }

    {$IFDEF Win32 }

    function regReadString(aKey: HKEY; const Path: String): String;
    var
      aRegistry : TRegistry;
      aPath     : String;
      aValue    : String;
    begin
      aRegistry:=TRegistry.Create;
      try
        with aRegistry do
        begin
          RootKey:=aKey;
          aPath:=Path;
          aValue:='';
          while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
          begin
            aValue:=strLastCh(aPath)+aValue;
            strStripLast(aPath);
          end;
          OpenKey(aPath,True);
          Result:=ReadString(aValue);
        end;
      finally
        aRegistry.Free;
      end;
    end;

    procedure regWriteString(aKey: HKEY; const Path,Value: String);
    var
      aRegistry : TRegistry;
      aPath     : String;
      aValue    : String;
    begin
      aRegistry:=TRegistry.Create;
      try
        with aRegistry do
        begin
          RootKey:=aKey;
          aPath:=Path;
          aValue:='';
          while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
          begin
            aValue:=strLastCh(aPath)+aValue;
            strStripLast(aPath);
          end;
          OpenKey(aPath,True);
          WriteString(aValue,Value);
        end;
      finally
        aRegistry.Free;
      end;
    end;

    (*!!!
    function regReadString(aKey: hKey; const Value: String): String;
    var
      aTmp  : array[0..255] of char;
      aCb,
      aType : Integer;
    begin
      Result:='';
      if aKey<> 0 then
      begin
        aCb:=Sizeof(aTmp)-1;
       { aData:=@aTmp; }
        if RegQueryValueEx(aKey,PChar(Value),nil,@aType,@aTmp,@aCb)=ERROR_SUCCESS then
           if aType=REG_SZ then Result:=String(aTmp);
      end;
    end; *)

    function regInfoString(const Value: String): String;
    var
      aKey : hKey;
    begin
      Result:='';
      if RegOpenKey(HKEY_LOCAL_MACHINE,REG_CURRENT_VERSION,aKey)=ERROR_SUCCESS then
      begin
        Result:=regReadString(aKey,Value);
        RegCloseKey(aKey);
      end;
    end;

    function regCurrentUser: String;
    begin
      Result:=regInfoString(REG_CURRENT_USER);
    end;

    function regCurrentCompany: String;
    begin
      Result:=regInfoString(REG_CURRENT_COMPANY);
    end;

    { Add a shell extension to the registry }
    procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
    var
      s, aPath : String;
    begin
      with TRegistry.Create do
      try
        RootKey := HKEY_CLASSES_ROOT;
        aPath   := aExt;
        if KeyExists(aPath) then
        begin
          OpenKey(aPath,False);
          S:=ReadString('');
          CloseKey;
          if S<>'' then
             if KeyExists(S) then
                aPath:=S;
        end;

        OpenKey(aPath+'\Shell\'+aCmd,True);
        WriteString('',aMenu);
        CloseKey;

        OpenKey(aPath+'\Shell\'+aCmd+'\Command',True);
        WriteString('',aExec + ' %1');
        CloseKey;
      finally
        Free;
      end;
    end;

    {$ENDIF}

    { other stuff }

    function MsgBox(const aTitle,aMsg: String; aFlag: Integer): Integer;
    var
      ActiveWindow : hWnd;
      WindowList   : Pointer;
      TmpA         : array[0..200] of char;
      TmpB         : array[0..100] of char;
    begin
      ActiveWindow:=GetActiveWindow;
      WindowList:= DisableTaskWindows(0);
      try
        StrPCopy(TmpB,aTitle);
        StrPCopy(TmpA,aMsg);
       {$IFDEF Win32}
        Result:=Windows.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
       {$ELSE}
        Result:=WinProcs.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
       {$ENDIF}
      finally
        EnableTaskWindows(WindowList);
        SetActiveWindow(ActiveWindow);
      end;
    end;

    function Question(const Msg: String):Boolean;
    begin
      if IsWin95 or IsWinNT then
        Result:=MsgBox(LoadStr(SMsgdlgConfirm),Msg, MB_ICONQUESTION or MB_YESNO)=IDYES
      else
        Result:=messageDlg(Msg,mtConfirmation,[mbYes,mbNo],0)=mrYes;
    end;

    procedure Information(const Msg: String);
    begin
      if IsWin95 or IsWinNT then
         MsgBox(LoadStr(SMsgdlgInformation), Msg, MB_ICONINFORMATION or MB_OK )
      else
         messageDlg(Msg,mtInformation,[mbOk],0);
    end;

    function Confirmation(const Msg: String): Word;
    begin
      if IsWin95 or IsWinNT then
         case MsgBox(LoadStr(SMsgDlgConfirm),Msg,MB_ICONQUESTION or MB_YESNOCANCEL) of
           IDYES    : Result := mrYes;
           IDNO     : Result := mrNo;
           IDCANCEL : Result := mrCancel;
           else       Result := mrCancel;
         end
      else
         Result:=MessageDlg(Msg,mtConfirmation,[mbYes,mbNo,mbCancel],0);
    end;

    { TPersistentRect }

    constructor TPersistentRect.Create;
    begin
      FRect:=rectSet(10,10,100,20);
    end;

    procedure TPersistentRect.Assign(Source: TPersistent);
    var
     Value: TPersistentRect;
    begin
      if Value is TPersistentRect then
      begin
        Value:=Source as TPersistentRect;
        FRect:=rectBounds(Value.Left,Value.Top,Value.Width,Value.Height);
        exit;
      end;
      inherited Assign(Source);
    end;

    procedure TPersistentRect.SetLeft(Value: Integer);
    begin
      if Value<>Left then
      begin
        if Assigned(FOnConvert) then
           Value:=FOnConvert(Self,Value,False);
        FRect:=rectBounds(Value,Top,Width,Height);
      end;
    end;

    procedure TPersistentRect.SetTop(Value: Integer);
    begin
      if Value<>Top then
      begin
        if Assigned(FOnConvert) then
           Value:=FOnConvert(Self,Value,False);
        FRect:=rectBounds(Left,Value,Width,Height);
      end;
    end;

    procedure TPersistentRect.SetHeight(Value: Integer);
    begin
      if Value<>Height then
      begin
        if Assigned(FOnConvert) then
           Value:=FOnConvert(Self,Value,False);
        FRect:=rectBounds(Left,Top,Width,Value);
      end;
    end;

    procedure TPersistentRect.SetWidth(Value: Integer);
    begin
      if Value<>Width then
      begin
        if Assigned(FOnConvert) then
           Value:=FOnConvert(Self,Value,False);
        FRect:=rectBounds(Left,Top,Value,Height);
      end;
    end;

    function  TPersistentRect.GetLeft: Integer;
    begin
      Result:=FRect.Left;
      if Assigned(FOnConvert) then
         Result:=FOnConvert(Self,Result,True);
    end;

    function  TPersistentRect.GetTop: Integer;
    begin
      Result:=FRect.Top;
      if Assigned(FOnConvert) then
         Result:=FOnConvert(Self,Result,True);
    end;

    function  TPersistentRect.GetHeight: Integer;
    begin
      Result:=rectHeight(FRect);
      if Assigned(FOnConvert) then
         Result:=FOnConvert(Self,Result,True);
    end;

    function  TPersistentRect.GetWidth: Integer;
    begin
      Result:=rectWidth(FRect);
      if Assigned(FOnConvert) then
         Result:=FOnConvert(Self,Result,True);
    end;

    {$IFDEF Win32}

    { TPersistentRegistry }

    function TPersistentRegistry.ReadComponent(const Name: String;
                                     Owner, Parent: TComponent): TComponent;
    var
      DataSize  : Integer;
      MemStream : TMemoryStream;
      Reader    : TReader;
    begin
      Result := nil;
      DataSize:=GetDataSize(Name);
      MemStream := TMemoryStream.Create;
      try
        MemStream.SetSize(DataSize);
        ReadBinaryData(Name,MemStream.Memory^,DataSize);
        MemStream.Position := 0;

        Reader := TReader.Create(MemStream, 256);
        try
          Reader.Parent := Parent;
          Result := Reader.ReadRootComponent(nil);
          if Owner <> nil then
            try
              Owner.InsertComponent(Result);
            except
              Result.Free;
              raise;
            end;
        finally
          Reader.Free;
        end;

      finally
        MemStream.Free;
      end;
    end;

    procedure TPersistentRegistry.WriteComponent(const Name: String; Component: TComponent);
    var
      MemStream: TMemoryStream;
    begin
      MemStream := TMemoryStream.Create;
      try
        MemStream.WriteComponent(Component);
        WriteBinaryData(Name, MemStream.Memory^, MemStream.Size);
      finally
        MemStream.Free;
      end;
    end;

    {$ENDIF}

    { TSystemMetric }

    constructor TSystemMetric.Create;
    begin
      inherited Create;
      Update;
    end;

    procedure TSystemMetric.Update;

      function GetSystemPoint(ax,ay: Integer):TPoint;
      begin
        Result:=Point(GetSystemMetrics(ax),GetSystemMetrics(ay));
      end;

    begin
      FMenuHeight    :=GetSystemMetrics(SM_CYMENU);
      FCaptionHeight :=GetSystemMetrics(SM_CYCAPTION);
      FBorder        :=GetSystemPoint(SM_CXBORDER,SM_CYBORDER);
      FFrame         :=GetSystemPoint(SM_CXFRAME,SM_CYFRAME);
      FDlgFrame      :=GetSystemPoint(SM_CXDLGFRAME,SM_CYDLGFRAME);
      FBitmap        :=GetSystemPoint(SM_CXSIZE,SM_CYSIZE);
      FHScroll       :=GetSystemPoint(SM_CXHSCROLL,SM_CYHSCROLL);
      FVScroll       :=GetSystemPoint(SM_CXVSCROLL,SM_CYVSCROLL);
      FThumb         :=GetSystemPoint(SM_CXHTHUMB,SM_CYVTHUMB);
      FFullScreen    :=GetSystemPoint(SM_CXFULLSCREEN,SM_CYFULLSCREEN);
      FMin           :=GetSystemPoint(SM_CXMIN,SM_CYMIN);
      FMinTrack      :=GetSystemPoint(SM_CXMINTRACK,SM_CYMINTRACK);
      FCursor        :=GetSystemPoint(SM_CXCURSOR,SM_CYCURSOR);
      FIcon          :=GetSystemPoint(SM_CXICON,SM_CYICON);
      FDoubleClick   :=GetSystemPoint(SM_CXDOUBLECLK,SM_CYDOUBLECLK);
      FIconSpacing   :=GetSystemPoint(SM_CXICONSPACING,SM_CYICONSPACING);
      FColorDepth    :=sysColorDepth;
    end;

    { TDesktopCanvas }

    constructor TDesktopCanvas.Create;
    begin
      inherited Create;
      DC:=GetDC(0);
      Handle:=DC;
    end;

    destructor  TDesktopCanvas.Destroy;
    begin
      Handle:=0;
      ReleaseDC(0, DC);
      inherited Destroy;
    end;

    {$IFNDEF Win32}

    procedure DoneXProcs; far;
    begin
      SysMetric.Free;
    end;

    {$ENDIF}

    initialization
      Randomize;

      SysMetric := TSystemMetric.Create;
      IsWin95   := (GetVersion and $FF00) >= $5F00;
      IsWinNT   := (GetVersion < $80000000);
      IsFabula  := nil;

    {$IFDEF Win32}
      xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
      case xLanguage of
        LANG_GERMAN    : xLangOfs := 70000;
        LANG_ENGLISH   : xLangOfs := 71000;
        LANG_SPANISH   : xLangOfs := 72000;
        LANG_RUSSIAN   : xLangOfs := 73000;
        LANG_ITALIAN   : xLangOfs := 74000;
        LANG_FRENCH    : xLangOfs := 75000;
        LANG_PORTUGUESE: xLangOfs := 76000;
        else             xLangOfs := 71000;
      end;
    {$ENDIF}

    {$IFDEF Win32}
    finalization
      SysMetric.Free;
    {$ELSE}
      AddExitProc(DoneXProcs);
    {$ENDIF}
    end.

[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]