home *** CD-ROM | disk | FTP | other *** search
/ Chip 2000 February / Chip_2000-02_cd.bin / zkuste / Delphi / navody / tt / xprocs.txt < prev   
Text File  |  1999-11-22  |  75KB  |  2,816 lines
  1. S.A.F.
  2.  
  3. xProcs.zip
  4. ==========
  5.  
  6. This is free function library can be use
  7. with Delphi 1.0 and Delphi 2.0. If offer
  8. over 150 functions in the areas or
  9. string, datetime, file, system, registry,
  10. bits, integer, floatingpoint, ...
  11.  
  12. The following files are contained in the zip:
  13.   xProcs.pas,.txt,.hlp,.kwf
  14.  
  15. For more info look into the .hlp.
  16.  
  17. If you've problems write eMail to :
  18.   100023.275@compuserve.com
  19.  
  20.  
  21. {*******************************************************}
  22. {                                                       }
  23. {       xTool - Component Collection                    }
  24. {                                                       }
  25. {       Copyright (c) 1995 Stefan B÷ther                }
  26. {                            stefc@fabula.com           }
  27. {*******************************************************}
  28. {
  29.   Please look also for our xTools-Nails function toolkit.
  30.   You'll find more information at
  31.      http://ourworld.compuserve.com/homepages/stefc/xprocs.htm
  32.  
  33.   Any comments and suggestions are welcome; please send to:
  34.      stefc@fabula.com.
  35.  
  36.    21.02.96  added TMonth & TDay type                                Stefc
  37.    22.02.96  added strFileLoad & strFileSave                         Stefc
  38.    09.03.96  correct sysTempPath                                     Stefc
  39.    09.03.96  added regXXXXX functions for access the registry        Stefc
  40.    24.03.96  added IsWinNT constant                                  Stefc
  41.    24.03.96  added SysMetric object                                  Stefc
  42.    26.03.96  added dateQuicken for controling date input with keys   Stefc
  43.    27.03.96  added TDesktopCanvas here                               Stefc
  44.    28.03.96  added LoadDIBitmap                                      Stefc
  45.    01.04.96  added Question function here                            Stefc
  46.    09.04.96  added sysSaverRunning added                             Stefc
  47.    12.04.96  added timeZoneOffset                                    Stefc
  48.    12.04.96  added timeToInt                                         Stefc
  49.    17.04.96  added strCmdLine                                        Stefc
  50.    17.04.96  added rectBounds                                        Stefc
  51.    17.04.96  added TPersistentRect class                             Stefc
  52.    19.04.96  added strDebug method                                   Stefc
  53.    21.04.96  changed TMonth added noneMonth                          km
  54.    21.04.96  added licence callback                                  Stefc
  55.    21.04.96  added strNiceDateDefault                                km
  56.    21.04.96  added simple strEncrpyt & strDecrypt                    Stefc
  57.    24.04.96  backport to 16 bit                                      Stefc
  58.    24.04.96  added Information method                                Stefc
  59.    24.04.96  use win messageBox with Win95 in Question & Information Stefc
  60.    09.05.96  new function ExtractName                                Stefc
  61.    10.05.96  Added TPersistentRegistry                               Stefc
  62.    12.05.96  fileExec                                                Stefc
  63.    14.05.96  New function Confirmation                               Stefc
  64.    16.05.96  New function strChange                                  Stefc
  65.    29.05.96  New functions comXXXXX                                  Stefc
  66.    09.06.96  New function strSearchReplace                           km
  67.    09.06.96  ported assembler strHash to plain pascal                Stefc
  68.    15.06.96  new variables xLanguage & xLangOfs                      Stefc
  69.    28.06.96  new method sysBeep                                      Stefc
  70.    28.06.96  new method intPercent                                   Stefc
  71.    10.07.96  make compatible with 16 Bit Delphi 1.0                  Stefc
  72.    14.07.96  fileLongName & fileShortName defined                    Stefc
  73.    15.07.96  Correct sysTempPath method                              Stefc
  74.    21.07.96  New functions strContains & strContainsU                Stefc
  75.    28.07.96  comIsCServe also check for xxx@compuServe.com           Stefc
  76.    31.07.96  added strCapitalize after idea from Fred N. Read        Stefc
  77.    04.08.96  strByteSize() now can also display Bytes                Stefc
  78.    05.08.96  added regWriteShellExt()                                Stefc
  79.    06.08.96  added sysColorDepth()                                   Stefc
  80.    07.08.96  added strSoundex()                                      Stefc
  81.    09.08.96  fixe some bugs in fileShellXXXX                         Stefc
  82.    26.08.96  Added registry functions from David W. Yutzy            Stefc
  83.    29.08.96  fileShellXXX now also aviable under 16 Bit              Stefc
  84.    05.09.96  Added regDelValue                                       Stefc
  85.    13.09.96  Added fltNegativ and fltPositiv                         Stefc
  86.    29.09.96  Added strTokenToStrings & strTokenFromStrings           Stefc
  87.    09.10.96  Added variant function                                  Stefc
  88.    29.10.96  intPrime now can be used for negative numbers           Stefc
  89.    29.10.96  fltEqualZero now returns true with FLTZERO              Stefc
  90.    29.10.96  fltCalc now use Float for greater precision             Stefc
  91.    29.10.96  correct strTokenCount                                   Stefc
  92.    19.11.96  better Windows NT detecting                             Stefc
  93.    28.11.96  correct above text (thanks to Clay Kollenborn-Shannon)  Stefc
  94.    12.01.96  added fileCopy function                                 Stefc
  95.    13.01.96  correct strProfile now it works also for 16-Bit         Stefc
  96.    13.01.96  get English Quicken keys from George Boomer             Stefc
  97.    14.01.96  make key in dateQuicken var to reset if on date change  Stefc
  98.    17.01.96  New functions strPos and strChangeU                     Stefc
  99.    19.01.96  new function fileTypeName after idea of P.Aschenbacher  Stefc
  100.    19.01.96  new function fileRedirectExec                           Stefc
  101.  
  102. }
  103. unit xProcs;
  104.  
  105. {$D-}
  106.  
  107. interface
  108.  
  109. {.$DEFINE German}
  110. {.$DEFINE English}
  111.  
  112. uses
  113.  {$IFDEF Win32} Windows, Registry, {$ELSE} WinTypes, WinProcs, {$ENDIF}
  114.   ShellAPI, Messages, Classes, Graphics;
  115.  
  116. type
  117.   Float = Extended;    { our type for float arithmetic }
  118.  
  119.  {$IFDEF Win32}        { our type for integer functions, Int_ is ever 32 bit }
  120.   Int_  = Integer;
  121.  {$ELSE}
  122.   Int_  = Longint;
  123.  {$ENDIF}
  124.  
  125. const
  126.   XCOMPANY        = 'Fabula Software';
  127.  
  128. const
  129.   { several important ASCII codes }
  130.   NULL            =  #0;
  131.   BACKSPACE       =  #8;
  132.   TAB             =  #9;
  133.   LF              = #10;
  134.   CR              = #13;
  135.   EOF_            = #26;    { 30.07.96 sb }
  136.   ESC             = #27;
  137.   BLANK           = #32;
  138.   SPACE           = BLANK;
  139.  
  140.   { digits as chars }
  141.   ZERO   = '0';  ONE  = '1';  TWO    = '2';  THREE  = '3';  FOUR  = '4';
  142.   FIVE   = '5';  SIX  = '6';  SEVEN  = '7';  EIGHT  = '8';  NINE  = '9';
  143.  
  144.   { special codes }
  145.   SLASH           = '\';     { used in filenames }
  146.   HEX_PREFIX      = '$';     { prefix for hexnumbers }
  147.  
  148.   CRLF            : PChar = CR+LF;
  149.  
  150.   { common computer sizes }
  151.   KBYTE           = Sizeof(Byte) shl 10;
  152.   MBYTE           = KBYTE        shl 10;
  153.   GBYTE           = MBYTE        shl 10;
  154.  
  155.   { Low floating point value }
  156.   FLTZERO         : Float = 0.00000001;
  157.  
  158.   DIGITS          : set of Char = [ZERO..NINE];
  159.  
  160.   { important registry keys / items }
  161.   REG_CURRENT_VERSION = 'Software\Microsoft\Windows\CurrentVersion';
  162.   REG_CURRENT_USER    = 'RegisteredOwner';
  163.   REG_CURRENT_COMPANY = 'RegisteredOrganization';
  164.  
  165.   PRIME_16       = 65521;
  166.   PRIME_32       = 2147483647;
  167.  
  168.   MINSHORTINT    = -128;               { 1.8.96 sb }
  169.   MAXSHORTINT    =  127;
  170.   MINBYTE        =  0;
  171.   MAXBYTE        =  255;
  172.   MINWORD        =  0;
  173.   MAXWORD        =  65535;
  174.  
  175. type
  176.   TMonth        = (NoneMonth,January,February,March,April,May,June,July,
  177.                    August,September,October,November,December);
  178.  
  179.   TDayOfWeek    = (Sunday,Monday,Tuesday,Wednesday,Thursday,Friday,Saturday);
  180.  
  181.   { Online eMail Service Provider }
  182.   TMailProvider = (mpCServe, mpInternet, mpNone);
  183.  
  184.   TLicCallback  = function ( var Code: Integer): Integer;
  185.  
  186.   TBit          = 0..31;
  187.  
  188.   { Search and Replace options }
  189.   TSROption     = (srWord,srCase,srAll);
  190.   TSROptions    = set of TsrOption;
  191.  
  192.   { Data types }
  193.   TDataType     = (dtInteger,dtBoolean,dtString,dtDate,dtTime,
  194.                    dtFloat,dtCurrency);
  195.  
  196. var
  197.   IsWin95,
  198.   IsWinNT   : Boolean;
  199.   IsFabula  : TLicCallBack;
  200.  
  201.   xLanguage : Integer;
  202.   xLangOfs  : Integer;
  203.  
  204. { bit manipulating }
  205. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  206. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  207. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  208. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  209.  
  210. { String functions }
  211. function  strHash(const S: String; LastBucket: Integer): Integer;
  212. function  strCut(const S: String; Len: Integer): String;
  213. function  strTrim(const S: String): String;
  214. function  strTrimA(const S: String): String;
  215. function  strTrimChA(const S: String; C: Char): String;
  216. function  strTrimChL(const S: String; C: Char): String;
  217. function  strTrimChR(const S: String; C: Char): String;
  218. function  strLeft(const S: String; Len: Integer): String;
  219. function  strLower(const S: String): String;
  220. function  strMake(C: Char; Len: Integer): String;
  221. function  strPadChL(const S: String; C: Char; Len: Integer): String;
  222. function  strPadChR(const S: String; C: Char; Len: Integer): String;
  223. function  strPadChC(const S: String; C: Char; Len: Integer): String;
  224. function  strPadL(const S: String; Len: Integer): String;
  225. function  strPadR(const S: String; Len: Integer): String;
  226. function  strPadC(const S: String; Len: Integer): String;
  227. function  strPadZeroL(const S: String; Len: Integer): String;
  228. function  strPos(const aSubstr,S: String; aOfs: Integer): Integer;
  229. procedure strChange(var S:String; const Src, Dest: String);
  230. function  strChangeU(const S,Source, Dest: String): String;
  231. function  strRight(const S: String; Len: Integer): String;
  232. function  strAddSlash(const S: String): String;
  233. function  strDelSlash(const S: String): String;
  234. function  strSpace(Len: Integer): String;
  235. function  strToken(var S: String; Seperator: Char): String;
  236. function  strTokenCount(S: String; Seperator: Char): Integer;
  237. function  strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  238. procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
  239. function  strTokenFromStrings(Seperator: Char; List: TStrings): String;
  240.  
  241. function  strUpper(const S: String): String;
  242. function  strOemAnsi(const S:String): String;
  243. function  strAnsiOem(const S:String): String;
  244. function  strEqual(const S1,S2: String): Boolean;
  245. function  strComp(const S1,S2: String): Boolean;
  246. function  strCompU(const S1,S2: String): Boolean;
  247. function  strContains(const S1,S2: String): Boolean;
  248. function  strContainsU(const S1,S2: String): Boolean;
  249. function  strNiceNum(const S: String): String;
  250. function  strNiceDateDefault(const S, Default: String): String;
  251. function  strNiceDate(const S: String): String;
  252. function  strNiceTime(const S: String): String;
  253. function  strNicePhone(const S: String): String;
  254. function  strReplace(const S: String; C: Char; const Replace: String): String;
  255. function  strCmdLine: String;
  256. function  strEncrypt(const S: String; Key: Word): String;
  257. function  strDecrypt(const S: String; Key: Word): String;
  258. function  strLastCh(const S: String): Char;
  259. procedure strStripLast(var S: String);
  260. function  strByteSize(Value: Longint): String;
  261. function  strSoundex(S: String): String;
  262. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  263. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  264. function  strCapitalize(const S: String): String;  { 31.07.96 sb }
  265.  
  266. {$IFDEF Win32}
  267. procedure strDebug(const S: String);
  268. function  strFileLoad(const aFile: String): String;
  269. procedure strFileSave(const aFile,aString: String);
  270. {$ENDIF}
  271.  
  272. { Integer functions }
  273. function  intCenter(a,b: Int_): Int_;
  274. function  intMax(a,b: Int_): Int_;
  275. function  intMin(a,b: Int_): Int_;
  276. function  intPow(Base,Expo: Integer): Int_;
  277. function  intPow10(Exponent: Integer): Int_;
  278. function  intSign(a: Int_): Integer;
  279. function  intZero(a: Int_; Len: Integer): String;
  280. function  intPrime(Value: Integer): Boolean;
  281. function  intPercent(a, b: Int_): Int_;
  282.  
  283. { Floatingpoint functions }
  284. function  fltAdd(P1,P2: Float; Decimals: Integer): Float;
  285. function  fltDiv(P1,P2: Float; Decimals: Integer): Float;
  286. function  fltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  287. function  fltEqualZero(P: Float): Boolean;
  288. function  fltGreaterZero(P: Float): Boolean;
  289. function  fltLessZero(P: Float): Boolean;
  290. function  fltNeg(P: Float; Negate: Boolean): Float;
  291. function  fltMul(P1,P2: Float; Decimals: Integer): Float;
  292. function  fltRound(P: Float; Decimals: Integer): Float;
  293. function  fltSub(P1,P2: Float; Decimals: Integer): Float;
  294. function  fltUnEqualZero(P: Float): Boolean;
  295. function  fltCalc(const Expr: String): Float;
  296. function  fltPower(a,n: Float): Float;
  297. function  fltPositiv(Value: Float): Float;
  298. function  fltNegativ(Value: Float): Float;
  299.  
  300. { Rectangle functions from Golden Software }
  301. function  rectHeight(const R: TRect): Integer;
  302. function  rectWidth(const R: TRect): Integer;
  303. procedure rectGrow(var R: TRect; Delta: Integer);
  304. procedure rectRelativeMove(var R: TRect; DX, DY: Integer);
  305. procedure rectMoveTo(var R: TRect; X, Y: Integer);
  306. function  rectSet(Left, Top, Right, Bottom: Integer): TRect;
  307. function  rectInclude(const R1, R2: TRect): Boolean;
  308. function  rectPoint(const R: TRect; P: TPoint): Boolean;
  309. function  rectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  310. function  rectIntersection(const R1, R2: TRect): TRect;
  311. function  rectIsIntersection(const R1, R2: TRect): Boolean;
  312. function  rectIsValid(const R: TRect): Boolean;
  313. function  rectsAreValid(const Arr: array of TRect): Boolean;
  314. function  rectNull: TRect;
  315. function  rectIsNull(const R: TRect): Boolean;
  316. function  rectIsSquare(const R: TRect): Boolean;
  317. function  rectCentralPoint(const R: TRect): TPoint;
  318. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  319.  
  320. {$IFDEF Win32}
  321. { Variant functions }
  322. function  varIIF( aTest: Boolean; TrueValue, FalseValue : Variant): Variant;
  323. procedure varDebug(const V: Variant);
  324. function  varToStr(const V: Variant): String;
  325. {$ENDIF}
  326.  
  327. { date functions }
  328. function  dateYear(D: TDateTime): Integer;
  329. function  dateMonth(D: TDateTime): Integer;
  330. function  dateDay(D: TDateTime): Integer;
  331. function  dateBeginOfYear(D: TDateTime): TDateTime;
  332. function  dateEndOfYear(D: TDateTime): TDateTime;
  333. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  334. function  dateEndOfMonth(D: TDateTime): TDateTime;
  335. function  dateWeekOfYear(D: TDateTime): Integer;
  336. function  dateDayOfYear(D: TDateTime): Integer;
  337. function  dateDayOfWeek(D: TDateTime): TDayOfWeek;
  338. function  dateLeapYear(D: TDateTime): Boolean;
  339. function  dateBeginOfQuarter(D: TDateTime): TDateTime;
  340. function  dateEndOfQuarter(D: TDateTime): TDateTime;
  341. function  dateBeginOfWeek(D: TDateTime;Weekday: Integer): TDateTime;
  342. function  dateDaysInMonth(D: TDateTime): Integer;
  343. function  dateQuicken(D: TDateTime; var Key: Char): TDateTime;
  344. {function  dateDiff(D1,D2: TDateTime): Integer;}
  345.  
  346. { time functions }
  347. function  timeHour(T: TDateTime): Integer;
  348. function  timeMin(T: TDateTime): Integer;
  349. function  timeSec(T: TDateTime): Integer;
  350. function  timeToInt(T: TDateTime): Integer;
  351.  
  352. {$IFDEF Win32}
  353. function  timeZoneOffset: Integer;
  354. {$ENDIF}
  355.  
  356. { com Functions }
  357. function  comIsCis(const S: String): Boolean;
  358. function  comIsInt(const S: String): Boolean;
  359. function  comCisToInt(const S: String): String;
  360. function  comIntToCis(const S: String): String;
  361. function  comFaxToCis(const S: String): String;
  362. function  comNormFax(const Name,Fax: String): String;
  363. function  comNormPhone(const Phone: String): String;
  364. function  comNormInt(const Name,Int: String): String;
  365. function  comNormCis(const Name,Cis: String): String;
  366.  
  367. { file functions }
  368. procedure fileShredder(const Filename: String);
  369. function  fileSize(const Filename: String): Longint;
  370. function  fileWildcard(const Filename: String): Boolean;
  371. function  fileShellOpen(const aFile: String): Boolean;
  372. function  fileShellPrint(const aFile: String): Boolean;
  373. function  fileCopy(const SourceFile, TargetFile: String): Boolean;
  374.  
  375. {$IFDEF Win32}
  376. function  fileTemp(const aExt: String): String;
  377. function  fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  378. function  fileRedirectExec(const aCmdLine: String; Strings: TStrings): Boolean;
  379. function  fileLongName(const aFile: String): String;
  380. function  fileShortName(const aFile: String): String;
  381. function  fileTypeName(const aFile: String): String;
  382. {$ENDIF}
  383. function  ExtractName(const Filename: String): String;
  384.  
  385. { system functions }
  386. function  sysTempPath:String;
  387. procedure sysDelay(aMs: Longint);
  388. procedure sysBeep;
  389. function  sysColorDepth: Integer;    { 06.08.96 sb }
  390.  
  391. {$IFDEF Win32}
  392. procedure sysSaverRunning(Active: Boolean);
  393. {$ENDIF}
  394.  
  395. { registry functions }
  396.  
  397. {$IFDEF Win32}
  398. function  regReadString(aKey: hKey; const Path: String): String;
  399. procedure regWriteString(aKey: hKey; const Path,Value: String);
  400. procedure regDelValue(aKey: hKey; const Path: String);
  401. function  regInfoString(const Value: String): String;
  402. function  regCurrentUser: String;
  403. function  regCurrentCompany: String;
  404. procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
  405.  
  406. { The following five functions came from David W. Yutzy / Celeste Software Services
  407.   Thanks for submitting us the methods !!
  408. }
  409. procedure regKeyList(aKey: HKEY; const Path:String; var aValue: TStringList);
  410. function  regValueExist(aKey: HKEY; const Path:String):Boolean;
  411. function  regWriteValue(aKey: HKEY; const Path: String; Value: Variant; Typ: TDataType): Boolean;
  412. function  regReadValue(aKey:HKEY; const Path:String; Typ: TDataType): Variant;
  413. procedure regValueList(aKey: HKEY; const Path:String; var aValue: TStringList);
  414. {$ENDIF}
  415.  
  416. { several functions }
  417. function  Question(const Msg: String):Boolean;
  418. procedure Information(const Msg: String);
  419. function  Confirmation(const Msg: String): Word;
  420.  
  421. type
  422.   { TRect that can be used persistent as property for components }
  423.   TUnitConvertEvent = function (Sender: TObject;
  424.     Value: Integer; Get: Boolean): Integer of object;
  425.  
  426.   TPersistentRect = class(TPersistent)
  427.   private
  428.     FRect      : TRect;
  429.     FOnConvert : TUnitConvertEvent;
  430.     procedure SetLeft(Value: Integer);
  431.     procedure SetTop(Value: Integer);
  432.     procedure SetHeight(Value: Integer);
  433.     procedure SetWidth(Value: Integer);
  434.     function  GetLeft: Integer;
  435.     function  GetTop: Integer;
  436.     function  GetHeight: Integer;
  437.     function  GetWidth: Integer;
  438.   public
  439.     constructor Create;
  440.     procedure Assign(Source: TPersistent); override;
  441.     property Rect: TRect read FRect;
  442.     property OnConvert: TUnitConvertEvent read FOnConvert write FOnConvert;
  443.   published
  444.     property Left  : Integer read GetLeft   write SetLeft;
  445.     property Top   : Integer read GetTop    write SetTop;
  446.     property Height: Integer read GetHeight write SetHeight;
  447.     property Width : Integer read GetWidth  write SetWidth;
  448.   end;
  449.  
  450. {$IFDEF Win32}
  451.   { Persistent access of components from the registry }
  452.   TPersistentRegistry = class(TRegistry)
  453.   public
  454.     function  ReadComponent(const Name: String; Owner, Parent: TComponent): TComponent;
  455.     procedure WriteComponent(const Name: String; Component: TComponent);
  456.   end;
  457. {$ENDIF
  458.  
  459.   { easy access of the system metrics }
  460.   TSystemMetric = class
  461.   private
  462.     FColorDepth,
  463.     FMenuHeight,
  464.     FCaptionHeight : Integer;
  465.     FBorder,
  466.     FFrame,
  467.     FDlgFrame,
  468.     FBitmap,
  469.     FHScroll,
  470.     FVScroll,
  471.     FThumb,
  472.     FFullScreen,
  473.     FMin,
  474.     FMinTrack,
  475.     FCursor,
  476.     FIcon,
  477.     FDoubleClick,
  478.     FIconSpacing : TPoint;
  479.   protected
  480.     constructor Create;
  481.     procedure Update;
  482.   public
  483.     property MenuHeight: Integer read FMenuHeight;
  484.     property CaptionHeight: Integer read FCaptionHeight;
  485.     property Border: TPoint read FBorder;
  486.     property Frame: TPoint read FFrame;
  487.     property DlgFrame: TPoint read FDlgFrame;
  488.     property Bitmap: TPoint read FBitmap;
  489.     property HScroll: TPoint read FHScroll;
  490.     property VScroll: TPoint read FVScroll;
  491.     property Thumb: TPoint read FThumb;
  492.     property FullScreen: TPoint read FFullScreen;
  493.     property Min: TPoint read FMin;
  494.     property MinTrack: TPoint read FMinTrack;
  495.     property Cursor: TPoint read FCursor;
  496.     property Icon: TPoint read FIcon;
  497.     property DoubleClick: TPoint read FDoubleClick;
  498.     property IconSpacing: TPoint read FIconSpacing;
  499.     property ColorDepth: Integer read FColorDepth;
  500.   end;
  501.  
  502. var
  503.   SysMetric: TSystemMetric;
  504.  
  505. type
  506.   TDesktopCanvas = class(TCanvas)
  507.   private
  508.     DC           : hDC;
  509.   public
  510.     constructor  Create;
  511.     destructor   Destroy; override;
  512.   end;
  513.  
  514. implementation
  515.  
  516. uses
  517.   SysUtils, Controls, Forms, Consts, Dialogs;
  518.  
  519. { bit manipulating }
  520. function bitSet(const Value: Int_; const TheBit: TBit): Boolean;
  521. begin
  522.   Result:= (Value and (1 shl TheBit)) <> 0;
  523. end;
  524.  
  525. function bitOn(const Value: Int_; const TheBit: TBit): Int_;
  526. begin
  527.   Result := Value or (1 shl TheBit);
  528. end;
  529.  
  530. function bitOff(const Value: Int_; const TheBit: TBit): Int_;
  531. begin
  532.   Result := Value and ((1 shl TheBit) xor $FFFFFFFF);
  533. end;
  534.  
  535. function bitToggle(const Value: Int_; const TheBit: TBit): Int_;
  536. begin
  537.   result := Value xor (1 shl TheBit);
  538. end;
  539.  
  540. { string methods }
  541.  
  542. function strHash(const S: String; LastBucket: Integer): Integer;
  543. var
  544.   i: Integer;
  545. begin
  546.   Result:=0;
  547.   for i := 1 to Length(S) do
  548.     Result := ((Result shl 3) xor Ord(S[i])) mod LastBucket;
  549. end;
  550.  
  551. function strTrim(const S: String): String;
  552. begin
  553.   Result:=StrTrimChR(StrTrimChL(S,BLANK),BLANK);
  554. end;
  555.  
  556. function strTrimA(const S: String): String;
  557. begin
  558.   Result:=StrTrimChA(S,BLANK);
  559. end;
  560.  
  561. function strTrimChA(const S: String; C: Char): String;
  562. var
  563.   I               : Word;
  564. begin
  565.   Result:=S;
  566.   for I:=Length(Result) downto 1 do
  567.     if Result[I]=C then Delete(Result,I,1);
  568. end;
  569.  
  570. function strTrimChL(const S: String; C: Char): String;
  571. begin
  572.   Result:=S;
  573.   while (Length(Result)>0) and (Result[1]=C) do Delete(Result,1,1);
  574. end;
  575.  
  576. function strTrimChR(const S: String; C: Char): String;
  577. begin
  578.   Result:=S;
  579.   while (Length(Result)> 0) and (Result[Length(Result)]=C) do
  580.     Delete(Result,Length(Result),1);
  581. end;
  582.  
  583. function strLeft(const S: String; Len: Integer): String;
  584. begin
  585.   Result:=Copy(S,1,Len);
  586. end;
  587.  
  588. function strLower(const S: String): String;
  589. begin
  590.   Result:=AnsiLowerCase(S);
  591. end;
  592.  
  593. function strMake(C: Char; Len: Integer): String;
  594. begin
  595.   Result:=strPadChL('',C,Len);
  596. end;
  597.  
  598. function strPadChL(const S: String; C: Char; Len: Integer): String;
  599. begin
  600.   Result:=S;
  601.   while Length(Result)<Len do Result:=C+Result;
  602. end;
  603.  
  604. function strPadChR(const S: String; C: Char; Len: Integer): String;
  605. begin
  606.   Result:=S;
  607.   while Length(Result)<Len do Result:=Result+C;
  608. end;
  609.  
  610. function strPadChC(const S: String; C: Char; Len: Integer): String;
  611. begin
  612.   Result:=S;
  613.   while Length(Result)<Len do
  614.   begin
  615.     Result:=Result+C;
  616.     if Length(Result)<Len then Result:=C+Result;
  617.   end;
  618. end;
  619.  
  620. function strPadL(const S: String; Len: Integer): String;
  621. begin
  622.   Result:=strPadChL(S,BLANK,Len);
  623. end;
  624.  
  625. function strPadC(const S: String; Len: Integer): String;
  626. begin
  627.   Result:=strPadChC(S,BLANK,Len);
  628. end;
  629.  
  630.  
  631. function strPadR(const S: String; Len: Integer): String;
  632. begin
  633.   Result:=strPadChR(S,BLANK,Len);
  634. end;
  635.  
  636. function strPadZeroL(const S: String; Len: Integer): String;
  637. begin
  638.   Result:=strPadChL(strTrim(S),ZERO,Len);
  639. end;
  640.  
  641. function strCut(const S: String; Len: Integer): String;
  642. begin
  643.   Result:=strLeft(strPadR(S,Len),Len);
  644. end;
  645.  
  646. function strRight(const S: String; Len: Integer): String;
  647. begin
  648.   if Len>=Length(S) then
  649.     Result:=S
  650.   else
  651.     Result:=Copy(S,Succ(Length(S))-Len,Len);
  652. end;
  653.  
  654. function strAddSlash(const S: String): String;
  655. begin
  656.   Result:=S;
  657.   if strLastCh(Result)<>SLASH then Result:=Result+SLASH;
  658. end;
  659.  
  660. function strDelSlash(const S: String): String;
  661. begin
  662.   Result:=S;
  663.   if strLastCh(Result)=SLASH then Delete(Result,Length(Result),1);
  664. end;
  665.  
  666. function strSpace(Len: Integer): String;
  667. begin
  668.   Result:=StrMake(BLANK,Len);
  669. end;
  670.  
  671. function strToken(var S: String; Seperator: Char): String;
  672. var
  673.   I               : Word;
  674. begin
  675.   I:=Pos(Seperator,S);
  676.   if I<>0 then
  677.   begin
  678.     Result:=System.Copy(S,1,I-1);
  679.     System.Delete(S,1,I);
  680.   end else
  681.   begin
  682.     Result:=S;
  683.     S:='';
  684.   end;
  685. end;
  686.  
  687. function strTokenCount(S: String; Seperator: Char): Integer;
  688. begin
  689.   Result:=0;
  690.   while S<>'' do begin            { 29.10.96 sb }
  691.     StrToken(S,Seperator);
  692.     Inc(Result);
  693.   end;
  694. end;
  695.  
  696. function strTokenAt(const S:String; Seperator: Char; At: Integer): String;
  697. var
  698.   j,i: Integer;
  699. begin
  700.   Result:='';
  701.   j := 1;
  702.   i := 0;
  703.   while (i<=At ) and (j<=Length(S)) do
  704.   begin
  705.     if S[j]=Seperator then
  706.        Inc(i)
  707.     else if i = At then
  708.        Result:=Result+S[j];
  709.     Inc(j);
  710.   end;
  711. end;
  712.  
  713. procedure strTokenToStrings(S: String; Seperator: Char; List: TStrings);
  714. var
  715.   Token: String;
  716. begin
  717.   List.Clear;
  718.   Token:=strToken(S,Seperator);
  719.   while Token<>'' do
  720.   begin
  721.     List.Add(Token);
  722.     Token:=strToken(S,Seperator);
  723.   end;
  724. end;
  725.  
  726. function strTokenFromStrings(Seperator: Char; List: TStrings): String;
  727. var
  728.   i: Integer;
  729. begin
  730.   Result:='';
  731.   for i:=0 to List.Count-1 do
  732.      if Result<>'' then
  733.        Result:=Result+Seperator+List[i]
  734.      else
  735.        Result:=List[i];
  736. end;
  737.  
  738. function strUpper(const S: String): String;
  739. begin
  740.   Result:=AnsiUpperCase(S);
  741. end;
  742.  
  743. function strOemAnsi(const S:String):String;
  744. begin
  745.  {$IFDEF Win32}
  746.   SetLength(Result,Length(S));
  747.  {$ELSE}
  748.   Result[0]:=Chr(Length(S));
  749.  {$ENDIF}
  750.   OemToAnsiBuff(@S[1],@Result[1],Length(S));
  751. end;
  752.  
  753. function strAnsiOem(const S:String): String;
  754. begin
  755.  {$IFDEF Win32}
  756.   SetLength(Result,Length(S));
  757.  {$ELSE}
  758.   Result[0]:=Chr(Length(S));
  759.  {$ENDIF}
  760.   AnsiToOemBuff(@S[1],@Result[1],Length(S));
  761. end;
  762.  
  763. function strEqual(const S1,S2: String): Boolean;
  764. begin
  765.   Result:=AnsiCompareText(S1,S2)=0;
  766. end;
  767.  
  768. function strCompU(const S1,S2: String) : Boolean;
  769. begin
  770.   Result:=strEqual(strLeft(S2,Length(S1)),S1);
  771. end;
  772.  
  773. function strComp(const S1,S2: String) : Boolean;
  774. begin
  775.   Result:=strLeft(S2,Length(S1))=S1;
  776. end;
  777.  
  778. function strContains(const S1,S2: String): Boolean;
  779. begin
  780.   Result:=Pos(S1,S2) > 0;
  781. end;
  782.  
  783. function strContainsU(const S1,S2: String): Boolean;
  784. begin
  785.   Result:=strContains(strUpper(S1),strUpper(S2));
  786. end;
  787.  
  788. function strNiceNum(const S: String) : String;
  789. var
  790.   i    : Integer;
  791.   Seps : set of Char;
  792. begin
  793.   Seps:=[ThousandSeparator,DecimalSeparator];
  794.   Result:= ZERO;
  795.   for i := 1 to Length(S) do
  796.     if S[i] in DIGITS + Seps then
  797.     begin
  798.       if S[i] = ThousandSeparator then
  799.          Result:=Result+DecimalSeparator
  800.       else
  801.          Result:=Result+S[i];
  802.       if S[i] In Seps then Seps:=[];
  803.     end
  804. end;
  805.  
  806. function strNiceDate(const S: String): String;
  807. begin
  808.   Result:=strNiceDateDefault(S, DateToStr(Date));
  809. end;
  810.  
  811. function  strNiceDateDefault(const S, Default: String): String;
  812. (* sinn der Procedure:
  813.    Irgendeinen String ⁿbergeben und in ein leidlich brauchbares Datum verwandeln.
  814.    Im Wesentlichen zum Abfangen des Kommazeichens auf dem Zehnerfeld.
  815.    eingabe 10 = Rⁿckgabe 10 des Laufenden Monats
  816.    eingabe 10.12 = Rⁿckgabe des 10.12. des laufenden Jahres.
  817.    eingabe 10.12.96 = Rⁿckgabe des Strings
  818.    eingabe 10,12,96 = Rⁿckgabe 10.12.95 (wird dann won STRtoDATE() gefressen)
  819.    Eine PlausbilitΣtskontrolle des Datums findet nicht Statt.
  820.    Geplante Erweiterung:
  821.    eingabe: +14  = Rⁿckgabe 14 Tage Weiter
  822.    eingabe: +3m  = Rⁿckgabe 3 Monate ab Heute
  823.    eingabe: +3w  = Rⁿckgabe 3 Wochen (3*7 Tage) ab Heute
  824.    Das gleiche auch RⁿckwΣrts mit  Minuszeichen
  825.    eingabe: e oder E oder f  = NΣchster Erster
  826.    eingabe: e+1m Erster des ⁿbernΣchsten Monats
  827.    Da lΣ▀t sich aber noch trefflich weiterspinnen
  828.  
  829.    EV. mit Quelle rausgeben, damit sich die EnglΣnder und Franzosen an
  830.    Ihren Datumsformaten selbst erfreuen k÷nnen und wir die passenden umsetzungen
  831.    bekommen. *)
  832. var
  833.   a        : array [0..2] of string[4];
  834.   heute    : string;
  835.   i,j      : integer;
  836. begin
  837.   a[0]:='';
  838.   a[1]:='';
  839.   a[2]:='';
  840.   heute := Default;
  841.  
  842.   j := 0;
  843.   for i := 0 to length(S) do
  844.     if S[i] in DIGITS then
  845.       a[j] := a[j]+S[i]
  846.     else if S[i] in [DateSeparator] then Inc(j);
  847.   for i := 0 to 2 do
  848.   if Length(a[i]) = 0 then
  849.     if I=2 then
  850.       a[i] :=copy(heute,i*3+1,4)
  851.     else
  852.       a[i] := copy(heute,i*3+1,2)
  853.   else
  854.     if length(a[i]) = 1 then
  855.       a[i] := '0'+a[i];
  856.  
  857.   Result:=a[0]+DateSeparator+a[1]+DateSeparator+a[2];
  858.   try
  859.     StrToDate(Result);
  860.   except
  861.     Result:=DateToStr(Date);
  862.   end;
  863. end;
  864.  
  865. function strNiceTime(const S: String): String;
  866. var
  867.   a   : array[0..2] of string[2];
  868.   i,j : integer;
  869. begin
  870.   j:= 0;
  871.   a[0]:= '';
  872.   a[1]:='';
  873.   a[2]:='';
  874.   for i:= 1 to length(S) do
  875.   begin
  876.     if S[i] in DIGITS then
  877.     begin
  878.       a[j] := a[j]+S[i];
  879.     end
  880.     else if S[i] in ['.',',',':'] then
  881.       inc(J);
  882.     if j > 2 then exit;
  883.   end;
  884.   for J := 0 to 2 do
  885.     if length(a[j]) = 1 then a[j] := '0'+a[j] else
  886.     if length(a[j]) = 0 then a[j] := '00';
  887.   Result := a[0]+TimeSeparator+a[1]+TimeSeparator+a[2];
  888. end;
  889.  
  890. function strNicePhone(const S: String): String;
  891. var
  892.   L : Integer;
  893. begin
  894.   if Length(S) > 3 then
  895.   begin
  896.     L:=(Length(S)+1) div 2;
  897.     Result:=strNicePhone(strLeft(S,L))+SPACE+strNicePhone(strRight(S,Length(S)-L));
  898.   end else
  899.     Result := S;
  900. end;
  901.  
  902. function strReplace(const S: String; C: Char; const Replace: String): String;
  903. var
  904.   i : Integer;
  905. begin
  906.   Result:='';
  907.   for i:=Length(S) downto 1 do
  908.     if S[i]=C then Result:=Replace+Result
  909.               else Result:=S[i]+Result;
  910. end;
  911.  
  912. function strPos(const aSubstr,S: String; aOfs: Integer): Integer;
  913. begin
  914.   Result:=Pos(aSubStr,Copy(S,aOfs,(Length(S)-aOfs)+1));
  915.   if (Result>0) and (aOfs>1) then Inc(Result,aOfs-1);
  916. end;
  917.  
  918. procedure strChange(var S:String; const Src, Dest: String);
  919. var
  920.   P : Integer;
  921. begin
  922.   P:=Pos(Src,S);
  923.   while P<>0 do
  924.   begin
  925.     Delete(S,P,Length(Src));
  926.     Insert(Dest,S,P);
  927.     Inc(P,Length(Dest));
  928.     P:=strPos(Src,S,P);
  929.   end;
  930. end;
  931.  
  932. function strChangeU(const S,Source, Dest: String): String;
  933. var
  934.   P    : Integer;
  935.   aSrc : String;
  936. begin
  937.   Result:=S;
  938.   aSrc:=strUpper(Source);
  939.   P:=Pos(aSrc,strUpper(Result));
  940.   while P<>0 do
  941.   begin
  942.     Delete(Result,P,Length(Source));
  943.     Insert(Dest,Result,P);
  944.     Inc(P,Length(Dest));
  945.     P:=strPos(aSrc,strUpper(Result),P);
  946.   end;
  947. end;
  948.  
  949.  
  950. function strCmdLine: String;
  951. var
  952.   i: Integer;
  953. begin
  954.   Result:='';
  955.   for i:=1 to ParamCount do Result:=Result+ParamStr(i)+' ';
  956.   Delete(Result,Length(Result),1);
  957. end;
  958.  
  959. { sends a string to debug windows inside the IDE }
  960. {$IFDEF Win32}
  961. procedure strDebug(const S: String);
  962. var
  963.   P    : PChar;
  964.   CPS  : TCopyDataStruct;
  965.   aWnd : hWnd;
  966. begin
  967.   aWnd := FindWindow('TfrmDbgTerm', nil);
  968.   if aWnd <> 0 then
  969.   begin
  970.     CPS.cbData := Length(S) + 2;
  971.     GetMem(P, CPS.cbData);
  972.     try
  973.       StrPCopy(P, S+CR);
  974.       CPS.lpData := P;
  975.       SendMessage(aWnd, WM_COPYDATA, 0, LParam(@CPS));
  976.     finally
  977.       FreeMem(P, Length(S)+2);
  978.     end;
  979.   end;
  980. end;
  981. {$ENDIF}
  982.  
  983. function strSoundex(S: String): String;
  984. const
  985.   CvTable : array['B'..'Z'] of char = (
  986.     '1', '2', '3', '0', '1',   {'B' .. 'F'}
  987.     '2', '0', '0', '2', '2',   {'G' .. 'K'}
  988.     '4', '5', '5', '0', '1',   {'L' .. 'P'}
  989.     '2', '6', '2', '3', '0',   {'Q' .. 'U'}
  990.     '1', '0', '2', '0', '2' ); {'V' .. 'Z'}
  991. var
  992.   i,j : Integer;
  993.   aGroup,Ch  : Char;
  994.  
  995.   function Group(Ch: Char): Char;
  996.   begin
  997.     if (Ch in ['B' .. 'Z']) and not (Ch In ['E','H','I','O','U','W','Y']) then
  998.        Result:=CvTable[Ch]
  999.     else
  1000.        Result:='0';
  1001.   end;
  1002.  
  1003. begin
  1004.   Result := '000';
  1005.   if S='' then exit;
  1006.  
  1007.   S:= strUpper(S);
  1008.   i:= 2;
  1009.   j:= 1;
  1010.   while (i <= Length(S)) and ( j<=3) do
  1011.   begin
  1012.     Ch := S[i];
  1013.     aGroup := Group(Ch);
  1014.     if (aGroup <> '0') and (Ch <> S[i-1]) and
  1015.        ((J=1) or (aGroup <> Result[j-1])) and
  1016.        ((i>2) or (aGroup <> Group(S[1]))) then
  1017.     begin
  1018.       Result[j] :=aGroup;
  1019.       Inc(j);
  1020.     end;
  1021.     Inc(i);
  1022.   end; {while}
  1023.  
  1024.   Result:=S[1]+'-'+Result;
  1025. end;
  1026.  
  1027. function strByteSize(Value: Longint): String;
  1028.  
  1029.   function FltToStr(F: Extended): String;
  1030.   begin
  1031.     Result:=FloatToStrF(Round(F),ffNumber,6,0);
  1032.   end;
  1033.  
  1034. begin
  1035.   if Value > GBYTE then
  1036.     Result:=FltTostr(Value / GBYTE)+' GB'
  1037.   else if Value > MBYTE then
  1038.     Result:=FltToStr(Value / MBYTE)+' MB'
  1039.   else if Value > KBYTE then
  1040.     Result:=FltTostr(Value / KBYTE)+' KB'
  1041.   else
  1042.     Result:=FltTostr(Value) +' Byte';   { 04.08.96 sb }
  1043. end;
  1044.  
  1045. const
  1046.   C1 = 52845;
  1047.   C2 = 22719;
  1048.  
  1049. function strEncrypt(const S: String; Key: Word): String;
  1050. var
  1051.   I: Integer;
  1052. begin
  1053.  {$IFDEF Win32}
  1054.   SetLength(Result,Length(S));
  1055.  {$ELSE}
  1056.    Result[0]:=Chr(Length(S));
  1057.  {$ENDIF}
  1058.   for I := 1 to Length(S) do begin
  1059.     Result[I] := Char(Ord(S[I]) xor (Key shr 8));
  1060.     Key := (Ord(Result[I]) + Key) * C1 + C2;
  1061.   end;
  1062. end;
  1063.  
  1064. function strDecrypt(const S: String; Key: Word): String;
  1065. var
  1066.   I: Integer;
  1067. begin
  1068.  {$IFDEF Win32}
  1069.   SetLength(Result,Length(S));
  1070.  {$ELSE}
  1071.    Result[0]:=Chr(Length(S));
  1072.  {$ENDIF}
  1073.   for I := 1 to Length(S) do begin
  1074.     Result[I] := char(Ord(S[I]) xor (Key shr 8));
  1075.     Key := (Ord(S[I]) + Key) * C1 + C2;
  1076.   end;
  1077. end;
  1078.  
  1079. function  strLastCh(const S: String): Char;
  1080. begin
  1081.   Result:=S[Length(S)];
  1082. end;
  1083.  
  1084. procedure strStripLast(var S: String);
  1085. begin
  1086.   if Length(S) > 0 then Delete(S,Length(S),1);
  1087. end;
  1088.  
  1089. procedure strSearchReplace(var S:String; const Source, Dest: String; Options: TSRoptions);
  1090. var hs,hs1,hs2,hs3: String;
  1091. var i,j : integer;
  1092.  
  1093. begin
  1094.  if  srCase in Options then
  1095.   begin
  1096.    hs := s;
  1097.    hs3 := source;
  1098.   end
  1099.  else
  1100.   begin
  1101.    hs:= StrUpper(s);
  1102.    hs3 := StrUpper(Source);
  1103.   end;
  1104.  hs1:= '';
  1105.  I:= pos(hs3,hs);
  1106.  j := length(hs3);
  1107.  while i > 0 do
  1108.  begin
  1109.    delete(hs,1,i+j-1); {Anfang Rest geΣndert 8.7.96 KM}
  1110.    hs1 := Hs1+copy(s,1,i-1); {Kopieren geΣndert 8.7.96 KM}
  1111.    delete(s,1,i-1); {L÷schen bis Anfang posgeΣndert 8.7.96 KM}
  1112.    hs2 := copy(s,1,j); {Bis ende pos Sichern}
  1113.    delete(s,1,j); {L÷schen bis ende Pos}
  1114.    if    (not (srWord in Options))
  1115.        or (pos(s[1],' .,:;-#''+*?=)(/&%$º"!{[]}\~<>|') > 0) then
  1116.     begin
  1117.      {Quelle durch ziel erstzen}
  1118.      hs1 := hs1+dest;
  1119.     end
  1120.    else
  1121.     begin
  1122.      hs1 := hs1+hs2;
  1123.     end;
  1124.    if srall in options then
  1125.     I:= pos(hs3,hs)
  1126.    else
  1127.     i :=0;
  1128.   end;
  1129.   s:= hs1+s;
  1130. end;
  1131.  
  1132. function  strProfile(const aFile, aSection, aEntry, aDefault: String): String;
  1133. var
  1134.   aTmp: array[0..255] of Char;
  1135.  {$IFNDEF Win32}
  1136.   pFile    : array[0..200] of char;
  1137.   pSection : array[0..100] of char;
  1138.   pEntry   : array[0..100] of char;
  1139.   pDefault : array[0..100] of char;
  1140.  {$ENDIF}
  1141. begin
  1142.  {$IFDEF Win32}
  1143.    GetPrivateProfileString(PChar(aSection), PChar(aEntry),
  1144.       PChar(aDefault), aTmp, Sizeof(aTmp)-1, PChar(aFile));
  1145.    Result:=StrPas(aTmp);
  1146.  {$ELSE}
  1147.     GetPrivateProfileString(StrPCopy(pSection,aSection),
  1148.       StrPCopy(pEntry,aEntry), StrPCopy(pDefault,aDefault),
  1149.         aTmp, Sizeof(aTmp)-1,  StrPCopy(pFile,aFile));
  1150.     Result:=StrPas(aTmp);
  1151.  {$ENDIF}
  1152. end;
  1153.  
  1154. function strCapitalize(const S: String): String;  { 31.07.96 sb }
  1155. var
  1156.   i      : Integer;
  1157.   Ch     : Char;
  1158.   First  : Boolean;
  1159. begin
  1160.   First  := True;
  1161.   Result := '';
  1162.   for i:=1 to Length(S) do
  1163.   begin
  1164.     Ch:=S[i];
  1165.     if Ch in [SPACE,'-','.'] then
  1166.        First:=True
  1167.     else if First then
  1168.     begin
  1169.       Ch:=strUpper(Ch)[1];
  1170.       First:=False;
  1171.     end;
  1172.     Result:=Result+Ch;
  1173.   end;
  1174. end;
  1175.  
  1176. {$IFDEF Win32}
  1177. function strFileLoad(const aFile: String): String;
  1178. var
  1179.   aStr : TStrings;
  1180. begin
  1181.   Result:='';
  1182.   aStr:=TStringList.Create;
  1183.   try
  1184.     aStr.LoadFromFile(aFile);
  1185.     Result:=aStr.Text;
  1186.   finally
  1187.     aStr.Free;
  1188.   end;
  1189. end;
  1190.  
  1191. procedure strFileSave(const aFile,aString: String);
  1192. var
  1193.   Stream: TStream;
  1194. begin
  1195.   Stream := TFileStream.Create(aFile, fmCreate);
  1196.   try
  1197.     Stream.WriteBuffer(Pointer(aString)^,Length(aString));
  1198.   finally
  1199.     Stream.Free;
  1200.   end;
  1201. end;
  1202. {$ENDIF}
  1203.  
  1204. { Integer stuff }
  1205.  
  1206. function IntCenter(a,b: Int_): Int_;
  1207. begin
  1208.   Result:=a div 2 - b div 2;
  1209. end;
  1210.  
  1211. function IntMax(a,b: Int_): Int_;
  1212. begin
  1213.   if a>b then Result:=a else Result:=b;
  1214. end;
  1215.  
  1216. function IntMin(a,b: Int_): Int_;
  1217. begin
  1218.   if a<b then Result:=a else Result:=b;
  1219. end;
  1220.  
  1221. function IntPow(Base,Expo: Integer): Int_;
  1222. var
  1223.   Loop             : Word;
  1224. begin
  1225.   Result:=1;
  1226.   for Loop:=1 to Expo do Result:=Result*Base;
  1227. end;
  1228.  
  1229. function IntPow10(Exponent: Integer): Int_;
  1230. begin
  1231.   Result:=IntPow(10,Exponent);
  1232. end;
  1233.  
  1234. function IntSign(a: Int_): Integer;
  1235. begin
  1236.   if a<0 then Result:=-1 else if a>0 then Result:=+1 else Result:= 0;
  1237. end;
  1238.  
  1239. function IntZero(a: Int_; Len: Integer): String;
  1240. begin
  1241.   Result:=strPadZeroL(IntToStr(a),Len);
  1242. end;
  1243.  
  1244. function IntPrime(Value: Integer): Boolean;
  1245. var
  1246.   i : integer;
  1247. begin
  1248.   Result:=False;
  1249.   Value:=Abs(Value);                     { 29.10.96 sb }
  1250.   if Value mod 2 <> 0 then
  1251.   begin
  1252.     i := 1;
  1253.     repeat
  1254.       i := i + 2;
  1255.       Result:= Value mod i = 0
  1256.     until Result or ( i > Trunc(sqrt(Value)) );
  1257.     Result:= not Result;
  1258.   end;
  1259. end;
  1260.  
  1261. function IntPercent(a, b : Int_): Int_;
  1262. begin
  1263.   Result := Trunc((a / b)*100);
  1264. end;
  1265.  
  1266. { Floating point stuff }
  1267.  
  1268. function FltAdd(P1,P2: Float; Decimals: Integer): Float;
  1269. begin
  1270.   P1    :=fltRound(P1,Decimals);
  1271.   P2    :=fltRound(P2,Decimals);
  1272.   Result:=fltRound(P1+P2,Decimals);
  1273. end;
  1274.  
  1275. function FltDiv(P1,P2: Float; Decimals: Integer): Float;
  1276. begin
  1277.   P1:=fltRound(P1,Decimals);
  1278.   P2:=fltRound(P2,Decimals);
  1279.   if P2=0.0 then P2:=FLTZERO;       { provide division by zero }
  1280.   Result:=fltRound(P1/P2,Decimals);
  1281. end;
  1282.  
  1283. function FltEqual(P1,P2: Float; Decimals: Integer): Boolean;
  1284. var
  1285.   Diff            : Float;
  1286. begin
  1287.   Diff:=fltSub(P1,P2,Decimals);
  1288.   Result:=fltEqualZero(Diff);
  1289. end;
  1290.  
  1291. function FltEqualZero(P: Float): Boolean;
  1292. begin
  1293.   Result:=(P>=-FLTZERO) and (P<=FLTZERO);          { 29.10.96 sb }
  1294. end;
  1295.  
  1296. function FltGreaterZero(P: Float): Boolean;
  1297. begin
  1298.   Result:=P>FLTZERO;
  1299. end;
  1300.  
  1301. function FltLessZero(P: Float): Boolean;
  1302. begin
  1303.   Result:=P<-FLTZERO;
  1304. end;
  1305.  
  1306. function FltNeg(P: Float; Negate: Boolean): Float;
  1307. begin
  1308.   if Negate then Result:=-P else Result:=P;
  1309. end;
  1310.  
  1311. function FltMul(P1,P2: Float; Decimals: Integer): Float;
  1312. begin
  1313.   P1    :=fltRound(P1,Decimals);
  1314.   P2    :=fltRound(P2,Decimals);
  1315.   Result:=fltRound(P1*P2,Decimals);
  1316. end;
  1317.  
  1318. function FltRound(P: Float; Decimals: Integer): Float;
  1319. var
  1320.   Factor  : LongInt;
  1321.   Help    : Float;
  1322. begin
  1323.   Factor:=IntPow10(Decimals);
  1324.   if P<0 then Help:=-0.5 else Help:=0.5;
  1325.   Result:=Int(P*Factor+Help)/Factor;
  1326.   if fltEqualZero(Result) then Result:=0.00;
  1327. end;
  1328.  
  1329. function FltSub(P1,P2: Float; Decimals: Integer): Float;
  1330. begin
  1331.   P1    :=fltRound(P1,Decimals);
  1332.   P2    :=fltRound(P2,Decimals);
  1333.   Result:=fltRound(P1-P2,Decimals);
  1334. end;
  1335.  
  1336. function FltUnEqualZero(P: Float): Boolean;
  1337. begin
  1338.   Result:=(P<-FLTZERO) or (P>FLTZERO)
  1339. end;
  1340.  
  1341. function FltCalc(const Expr: String): Float;
  1342. const
  1343.   STACKSIZE = 10;
  1344. var
  1345.   Stack   : array[0..STACKSIZE] of Float;    { 29.10.96 sb }
  1346.   oStack  : array[0..STACKSIZE] of char;
  1347.   z,n     : Float;
  1348.   i,j,m   : integer;
  1349.   Bracket : boolean;
  1350. begin
  1351.   Bracket:= False; j := 0; n:= 1;z:=0; m:=1;
  1352.   for i := 1 to Length(Expr) do
  1353.   begin
  1354.     if not Bracket  then
  1355.        case Expr[i] of
  1356.          '0' .. '9': begin
  1357.                        z:=z*10+ord(Expr[i])-ord('0');
  1358.                        n:=n*m;
  1359.                      end;
  1360.          ',',#46   : m := 10;
  1361.          '('       : Bracket := True; {hier Klammeranfang merken, ZΣhler!!}
  1362.          '*','x',
  1363.          'X',
  1364.          '/','+'   : begin
  1365.                        Stack[j] := z/n;
  1366.                        oStack[j] := Expr[i];
  1367.                        Inc(j);
  1368.                        m:=1;z:=0;n:=1;
  1369.                      end;
  1370.        end {case}
  1371.     else
  1372.        Bracket:= Expr[i]<> ')'; {hier Rekursiver Aufruf, ZΣhler !!};
  1373.   end;
  1374.   Stack[j] := z/n;
  1375.   for i := 1 to j do
  1376.     case oStack[i-1] of
  1377.       '*','x','X' :  Stack[i]:= Stack[i-1]*Stack[i];
  1378.       '/'         :  Stack[i]:= Stack[i-1]/Stack[i];
  1379.       '+'         :  Stack[i]:= Stack[i-1]+Stack[i];
  1380.     end;
  1381.   Result:= Stack[j];
  1382. end;
  1383.  
  1384. function fltPower(a, n: Float): Float;
  1385. begin
  1386.   Result:=Exp(n * Ln(a));
  1387. end;
  1388.  
  1389. function fltPositiv(Value: Float): Float;
  1390. begin
  1391.   Result:=Value;
  1392.   if Value < 0.0 then Result:= 0.0;
  1393. end;
  1394.  
  1395. function fltNegativ(Value: Float): Float;
  1396. begin
  1397.   Result:=Value;
  1398.   if Value > 0.0 then Result:= 0.0;
  1399. end;
  1400.  
  1401. { Rectangle Calculations }
  1402.  
  1403. function RectHeight(const R: TRect): Integer;
  1404. begin
  1405.   Result := R.Bottom - R.Top;
  1406. end;
  1407.  
  1408. function RectWidth(const R: TRect): Integer;
  1409. begin
  1410.   Result := R.Right - R.Left;
  1411. end;
  1412.  
  1413. procedure RectGrow(var R: TRect; Delta: Integer);
  1414. begin
  1415.   with R do
  1416.   begin
  1417.     Dec(Left, Delta);
  1418.     Dec(Top, Delta);
  1419.     Inc(Right, Delta);
  1420.     Inc(Bottom, Delta);
  1421.   end;
  1422. end;
  1423.  
  1424. procedure RectRelativeMove(var R: TRect; DX, DY: Integer);
  1425. begin
  1426.   with R do
  1427.   begin
  1428.     Inc(Left, DX);
  1429.     Inc(Right, DX);
  1430.     Inc(Top, DY);
  1431.     Inc(Bottom, DY);
  1432.   end;
  1433. end;
  1434.  
  1435. procedure RectMoveTo(var R: TRect; X, Y: Integer);
  1436. begin
  1437.   with R do
  1438.   begin
  1439.     Right := X + Right - Left;
  1440.     Bottom := Y + Bottom - Top;
  1441.     Left := X;
  1442.     Top := Y;
  1443.   end;
  1444. end;
  1445.  
  1446. function RectSet(Left, Top, Right, Bottom: Integer): TRect;
  1447. begin
  1448.   Result.Left := Left;
  1449.   Result.Top := Top;
  1450.   Result.Right := Right;
  1451.   Result.Bottom := Bottom;
  1452. end;
  1453.  
  1454. function RectSetPoint(const TopLeft, BottomRight: TPoint): TRect;
  1455. begin
  1456.   Result.TopLeft := TopLeft;
  1457.   Result.BottomRight := BottomRight;
  1458. end;
  1459.  
  1460. function RectInclude(const R1, R2: TRect): Boolean;
  1461. begin
  1462.   Result := (R1.Left >= R2.Left) and (R1.Top >= R2.Top)
  1463.     and (R1.Right <= R2.Right) and (R1.Bottom <= R2.Bottom);
  1464. end;
  1465.  
  1466. function  RectPoint(const R: TRect; P: TPoint): Boolean;
  1467. begin
  1468.   Result := (p.x>r.left) and (p.x<r.right) and (p.y>r.top) and (p.y<r.bottom);
  1469. end;
  1470.  
  1471. function RectIntersection(const R1, R2: TRect): TRect;
  1472. begin
  1473.   with Result do
  1474.   begin
  1475.     Left := intMax(R1.Left, R2.Left);
  1476.     Top := intMax(R1.Top, R2.Top);
  1477.     Right := intMin(R1.Right, R2.Right);
  1478.     Bottom := intMin(R1.Bottom, R2.Bottom);
  1479.   end;
  1480.  
  1481.   if not RectIsValid(Result) then
  1482.     Result := RectSet(0, 0, 0, 0);
  1483. end;
  1484.  
  1485. function RectIsIntersection(const R1, R2: TRect): Boolean;
  1486. begin
  1487.   Result := not RectIsNull(RectIntersection(R1, R2));
  1488. end;
  1489.  
  1490. function RectIsValid(const R: TRect): Boolean;
  1491. begin
  1492.   with R do
  1493.     Result := (Left <= Right) and (Top <= Bottom);
  1494. end;
  1495.  
  1496. function RectsAreValid(const Arr: array of TRect): Boolean;
  1497. var
  1498.   I: Integer;
  1499. begin
  1500.   for I := Low(Arr) to High(Arr) do
  1501.     if not RectIsValid(Arr[I]) then
  1502.     begin
  1503.       Result := False;
  1504.       exit;
  1505.     end;
  1506.   Result := True;
  1507. end;
  1508.  
  1509. function RectNull: TRect;
  1510. begin
  1511.   Result := RectSet(0, 0, 0, 0);
  1512. end;
  1513.  
  1514. function RectIsNull(const R: TRect): Boolean;
  1515. begin
  1516.   with R do
  1517.     Result := (Left = 0) and (Right = 0) and (Top = 0) and (Bottom = 0);
  1518. end;
  1519.  
  1520. function RectIsSquare(const R: TRect): Boolean;
  1521. begin
  1522.   Result := RectHeight(R) = RectWidth(R);
  1523. end;
  1524.  
  1525. function RectCentralPoint(const R: TRect): TPoint;
  1526. begin
  1527.   Result.X := R.Left + (RectWidth(R) div 2);
  1528.   Result.Y := R.Top + (RectHeight(R) div 2);
  1529. end;
  1530.  
  1531. function  rectBounds(aLeft,aTop,aWidth,aHeight: Integer): TRect;
  1532. begin
  1533.   Result:=rectSet(aLeft,aTop,aLeft+aWidth,aTop+aHeight);
  1534. end;
  1535.  
  1536. { variant functions }
  1537.  
  1538. {$IFDEF Win32}
  1539. function varIIF( aTest: Boolean; TrueValue, FalseValue : Variant): Variant;
  1540. begin
  1541.   if aTest then  Result := TrueValue else Result := FalseValue;
  1542. end;
  1543.  
  1544. procedure varDebug(const V: Variant);
  1545. begin
  1546.    strDebug(varToStr(v));
  1547. end;
  1548.  
  1549. function varToStr(const V: Variant): String;
  1550. begin
  1551.   case TVarData(v).vType of
  1552.     varSmallInt : Result := IntToStr(TVarData(v).VSmallInt);
  1553.     varInteger  : Result := IntToStr(TVarData(v).VInteger);
  1554.     varSingle   : Result := FloatToStr(TVarData(v).VSingle);
  1555.     varDouble   : Result := FloatToStr(TVarData(v).VDouble);
  1556.     varCurrency : Result := FloatToStr(TVarData(v).VCurrency);
  1557.     varDate     : Result := DateToStr(TVarData(v).VDate);
  1558.     varBoolean  : Result := varIIf(TVarData(v).VBoolean, 'True', 'False');
  1559.     varByte     : Result := IntToStr(TVarData(v).VByte);
  1560.     varString   : Result := StrPas(TVarData(v).VString);
  1561.     varEmpty,
  1562.     varNull,
  1563.     varVariant,
  1564.     varUnknown,
  1565.     varTypeMask,
  1566.     varArray,
  1567.     varByRef,
  1568.     varDispatch,
  1569.     varError    : Result := '';
  1570.   end;
  1571. end;
  1572.  
  1573. {$ENDIF}
  1574.  
  1575.  
  1576. { file functions }
  1577.  
  1578. procedure fileShredder(const Filename: String);
  1579. var
  1580.   aFile : Integer;
  1581.   aSize : Integer;
  1582.   P     : Pointer;
  1583. begin
  1584.   aSize:=fileSize(Filename);
  1585.   aFile:=FileOpen(FileName,fmOpenReadWrite);
  1586.   try
  1587.     Getmem(P,aSize);
  1588.     fillchar(P^,aSize,'X');
  1589.     FileWrite(aFile,P^,aSize);
  1590.     Freemem(P,aSize);
  1591.   finally
  1592.     FileClose(aFile);
  1593.     DeleteFile(Filename);
  1594.   end;
  1595. end;
  1596.  
  1597. function fileSize(const FileName: String): LongInt;
  1598. var
  1599.   SearchRec       : TSearchRec;
  1600. begin                                       { !Win32! -> GetFileSize }
  1601.   if FindFirst(FileName,faAnyFile,SearchRec)=0
  1602.     then Result:=SearchRec.Size
  1603.     else Result:=0;
  1604. end;
  1605.  
  1606. function fileWildcard(const Filename: String): Boolean;
  1607. begin
  1608.   Result:=(Pos('*',Filename)<>0) or (Pos('?',Filename)<>0);
  1609. end;
  1610.  
  1611. function fileShellOpen(const aFile: String): Boolean;
  1612. var
  1613.   Tmp: array[0..100] of char;
  1614. begin
  1615.   Result := ShellExecute( Application.Handle,
  1616.     'open', StrPCopy(Tmp,aFile), nil, nil, SW_NORMAL) > 32;
  1617. end;
  1618.  
  1619. function fileShellPrint(const aFile: String): Boolean;
  1620. var
  1621.   Tmp: array[0..100] of char;
  1622. begin
  1623.   Result := ShellExecute( Application.Handle,
  1624.     'print', StrPCopy(Tmp,aFile), nil, nil, SW_HIDE) > 32;
  1625. end;
  1626.  
  1627. function fileCopy(const SourceFile, TargetFile: String): Boolean;
  1628. const
  1629.   BlockSize = 1024 * 16;
  1630. var
  1631.   FSource,FTarget : Integer;
  1632.   FFileSize       : Longint;
  1633.   BRead,Bwrite    : Word;
  1634.   Buffer          : Pointer;
  1635. begin
  1636.   Result:=False;
  1637.   FSource:=FileOpen(SourceFile,fmOpenRead+fmShareDenyNone);  { Open Source }
  1638.   if FSource>=0 then
  1639.   try
  1640.     FFileSize:=FileSeek(FSource, 0, soFromEnd);
  1641.     FTarget:=FileCreate(TargetFile);            { Open Target }
  1642.     try
  1643.       getmem(Buffer,BlockSize);
  1644.       try
  1645.         FileSeek(FSource,0,soFromBeginning);
  1646.         repeat
  1647.           BRead:=FileRead(FSource,Buffer^,BlockSize);
  1648.           BWrite:=FileWrite(FTarget,Buffer^,Bread);
  1649.         until (Bread=0) or (Bread<>BWrite);
  1650.         if Bread=Bwrite then
  1651.            Result:=True;
  1652.       finally
  1653.         freemem(Buffer,BlockSize);
  1654.       end;
  1655.       FileSetDate(FTarget, FileGetDate(FSource));
  1656.     finally
  1657.       FileClose(FTarget);
  1658.     end;
  1659.   finally
  1660.     FileClose(FSource);
  1661.   end;
  1662. end;
  1663.  
  1664.  
  1665. {$IFDEF Win32}
  1666. function fileTemp(const aExt: String): String;
  1667. var
  1668.   Buffer: array[0..1023] of Char;
  1669.   aFile : String;
  1670. begin
  1671.   GetTempPath(Sizeof(Buffer)-1,Buffer);
  1672.   GetTempFileName(Buffer,'TMP',0,Buffer);
  1673.   SetString(aFile, Buffer, StrLen(Buffer));
  1674.   Result:=ChangeFileExt(aFile,aExt);
  1675.   RenameFile(aFile,Result);
  1676. end;
  1677.  
  1678. function fileExec(const aCmdLine: String; aHide, aWait: Boolean): Boolean;
  1679. var
  1680.   StartupInfo : TStartupInfo;
  1681.   ProcessInfo : TProcessInformation;
  1682. begin
  1683.   {setup the startup information for the application }
  1684.   FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  1685.   with StartupInfo do
  1686.   begin
  1687.     cb:= SizeOf(TStartupInfo);
  1688.     dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK;
  1689.     if aHide then wShowWindow:= SW_HIDE
  1690.              else wShowWindow:= SW_SHOWNORMAL;
  1691.   end;
  1692.  
  1693.   Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
  1694.                NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  1695.   if aWait then
  1696.      if Result then
  1697.      begin
  1698.        WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
  1699.        WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
  1700.      end;
  1701. end;
  1702.  
  1703. function fileRedirectExec(const aCmdLine: String; Strings: TStrings): Boolean;
  1704. var
  1705.   StartupInfo : TStartupInfo;
  1706.   ProcessInfo : TProcessInformation;
  1707.   aOutput     : Integer;
  1708.   aFile       : String;
  1709. begin
  1710.   Strings.Clear;
  1711.  
  1712.   { Create temp. file for output }
  1713.   aFile:=FileTemp('.tmp');
  1714.   aOutput:=FileCreate(aFile);
  1715.   try
  1716.     {setup the startup information for the application }
  1717.     FillChar(StartupInfo, SizeOf(TStartupInfo), 0);
  1718.     with StartupInfo do
  1719.     begin
  1720.       cb:= SizeOf(TStartupInfo);
  1721.       dwFlags:= STARTF_USESHOWWINDOW or STARTF_FORCEONFEEDBACK or
  1722.                 STARTF_USESTDHANDLES;
  1723.       wShowWindow:= SW_HIDE;
  1724.       hStdInput:= INVALID_HANDLE_VALUE;
  1725.       hStdOutput:= aOutput;
  1726.       hStdError:= INVALID_HANDLE_VALUE;
  1727.     end;
  1728.  
  1729.     Result := CreateProcess(nil,PChar(aCmdLine), nil, nil, False,
  1730.                  NORMAL_PRIORITY_CLASS, nil, nil, StartupInfo, ProcessInfo);
  1731.     if Result then
  1732.     begin
  1733.       WaitForInputIdle(ProcessInfo.hProcess, INFINITE);
  1734.       WaitForSingleObject(ProcessInfo.hProcess, INFINITE);
  1735.     end;
  1736.   finally
  1737.     FileClose(aOutput);
  1738.     Strings.LoadFromFile(aFile);
  1739.     DeleteFile(aFile);
  1740.   end;
  1741. end;
  1742.  
  1743.  
  1744. function  fileLongName(const aFile: String): String;
  1745. var
  1746.   aInfo: TSHFileInfo;
  1747. begin
  1748.   if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_DISPLAYNAME)<>0 then
  1749.      Result:=StrPas(aInfo.szDisplayName)
  1750.   else
  1751.      Result:=aFile;
  1752. end;
  1753.  
  1754. function  fileTypeName(const aFile: String): String;
  1755. var
  1756.   aInfo: TSHFileInfo;
  1757. begin
  1758.   if SHGetFileInfo(PChar(aFile),0,aInfo,Sizeof(aInfo),SHGFI_TYPENAME)<>0 then
  1759.      Result:=StrPas(aInfo.szTypeName)
  1760.   else begin
  1761.      Result:=ExtractFileExt(aFile);
  1762.      Delete(Result,1,1);
  1763.      Result:=strUpper(Result)+' File';
  1764.   end;
  1765. end;
  1766.  
  1767.  
  1768. function  fileShortName(const aFile: String): String;
  1769. var
  1770.   aTmp: array[0..255] of char;
  1771. begin
  1772.   if GetShortPathName(PChar(aFile),aTmp,Sizeof(aTmp)-1)=0 then
  1773.      Result:=aFile
  1774.   else
  1775.      Result:=StrPas(aTmp);
  1776. end;
  1777.  
  1778. {$ENDIF}
  1779.  
  1780. function ExtractName(const Filename: String): String;
  1781. var
  1782.   aExt : String;
  1783.   aPos : Integer;
  1784. begin
  1785.   aExt:=ExtractFileExt(Filename);
  1786.   Result:=ExtractFileName(Filename);
  1787.   if aExt <> '' then
  1788.   begin
  1789.     aPos:=Pos(aExt,Result);
  1790.     if aPos>0 then
  1791.        Delete(Result,aPos,Length(aExt));
  1792.   end;
  1793. end;
  1794.  
  1795. { date calculations }
  1796.  
  1797. function  dateYear(D: TDateTime): Integer;
  1798. var
  1799.   Year,Month,Day : Word;
  1800. begin
  1801.   DecodeDate(D,Year,Month,Day);
  1802.   Result:=Year;
  1803. end;
  1804.  
  1805. function  dateMonth(D: TDateTime): Integer;
  1806. var
  1807.   Year,Month,Day : Word;
  1808. begin
  1809.   DecodeDate(D,Year,Month,Day);
  1810.   Result:=Month;
  1811. end;
  1812.  
  1813. function  dateBeginOfYear(D: TDateTime): TDateTime;
  1814. var
  1815.   Year,Month,Day : Word;
  1816. begin
  1817.   DecodeDate(D,Year,Month,Day);
  1818.   Result:=EncodeDate(Year,1,1);
  1819. end;
  1820.  
  1821. function  dateEndOfYear(D: TDateTime): TDateTime;
  1822. var
  1823.   Year,Month,Day : Word;
  1824. begin
  1825.   DecodeDate(D,Year,Month,Day);
  1826.   Result:=EncodeDate(Year,12,31);
  1827. end;
  1828.  
  1829. function  dateBeginOfMonth(D: TDateTime): TDateTime;
  1830. var
  1831.   Year,Month,Day : Word;
  1832. begin
  1833.   DecodeDate(D,Year,Month,Day);
  1834.   Result:=EncodeDate(Year,Month,1);
  1835. end;
  1836.  
  1837. function  dateEndOfMonth(D: TDateTime): TDateTime;
  1838. var
  1839.   Year,Month,Day : Word;
  1840. begin
  1841.   DecodeDate(D,Year,Month,Day);
  1842.   if Month=12 then
  1843.   begin
  1844.     Inc(Year);
  1845.     Month:=1;
  1846.   end else
  1847.     Inc(Month);
  1848.   Result:=EncodeDate(Year,Month,1)-1;
  1849. end;
  1850.  
  1851. function dateWeekOfYear(D: TDateTime): Integer; { Armin Hanisch }
  1852. const
  1853.   t1: array[1..7] of ShortInt = ( -1,  0,  1,  2,  3, -3, -2);
  1854.   t2: array[1..7] of ShortInt = ( -4,  2,  1,  0, -1, -2, -3);
  1855. var
  1856.   doy1,
  1857.   doy2    : Integer;
  1858.   NewYear : TDateTime;
  1859. begin
  1860.   NewYear:=dateBeginOfYear(D);
  1861.   doy1 := dateDayofYear(D) + t1[DayOfWeek(NewYear)];
  1862.   doy2 := dateDayofYear(D) + t2[DayOfWeek(D)];
  1863.   if doy1 <= 0 then
  1864.     Result := dateWeekOfYear(NewYear-1)
  1865.   else if (doy2 >= dateDayofYear(dateEndOfYear(NewYear))) then
  1866.     Result:= 1
  1867.   else
  1868.     Result:=(doy1-1) div 7+1;
  1869. end;
  1870.  
  1871. function dateDayOfYear(D: TDateTime): Integer;
  1872. begin
  1873.   Result:=Trunc(D-dateBeginOfYear(D))+1;
  1874. end;
  1875.  
  1876. function dateDayOfWeek(D: TDateTime): TDayOfWeek;
  1877. begin
  1878.   Result:=TDayOfWeek(Pred(DayOfWeek(D)));
  1879. end;
  1880.  
  1881. function dateLeapYear(D: TDateTime): Boolean;
  1882. var
  1883.   Year,Month,Day: Word;
  1884. begin
  1885.   DecodeDate(D,Year,Month,Day);
  1886.   Result:=(Year mod 4 = 0) and ((Year mod 100 <> 0) or (Year mod 400 = 0));
  1887. end;
  1888.  
  1889. function dateBeginOfQuarter(D: TDateTime):TDateTime;
  1890. var
  1891.   Year,Month,Day : Word;
  1892. begin
  1893.   DecodeDate(D,Year,Month,Day);
  1894.   Result:=EncodeDate(Year,((Month-1 div 3) * 3)+1,1);
  1895. end;
  1896.  
  1897. function dateEndOfQuarter(D: TDateTime): TDateTime;
  1898. begin
  1899.   Result:=dateBeginOfQuarter(dateBeginOfQuarter(D)+(3*31))-1;
  1900. end;
  1901.  
  1902. function dateBeginOfWeek(D: TDateTime; Weekday: Integer): TDateTime;
  1903. begin
  1904.   Result:=D;
  1905.   while DayOfWeek(Result)<>Weekday do Result:=Result-1;
  1906. end;
  1907.  
  1908. function dateDaysInMonth(D: TDateTime): Integer;
  1909. const
  1910.   DaysPerMonth: array[1..12] of Byte= (31,28,31,30,31,30,31,31,30,31,30,31);
  1911. var
  1912.   Month: Integer;
  1913. begin
  1914.   Month:=dateMonth(D);
  1915.   Result:=DaysPerMonth[Month];
  1916.   if (Month=2) and dateLeapYear(D) then Inc(Result);
  1917. end;
  1918.  
  1919. function dateDay(D: TDateTime): Integer;
  1920. var
  1921.   Year,Month,Day : Word;
  1922. begin
  1923.   DecodeDate(D,Year,Month,Day);
  1924.   Result:=Day;
  1925. end;
  1926.  
  1927. function dateQuicken(D: TDateTime; var Key: Char): TDateTime;
  1928. const
  1929.  {$IFDEF German}
  1930.   _ToDay    = 'H';
  1931.   _PrevYear = 'J';
  1932.   _NextYear = 'R';
  1933.   _PrevMonth= 'M';
  1934.   _NextMonth= 'T';
  1935.   _BeginQuart='Q';
  1936.   _EndQuart  ='U';
  1937.  {$ELSE}
  1938.   _ToDay    = 'T';
  1939.   _PrevYear = 'Y';
  1940.   _NextYear = 'R';
  1941.   _PrevMonth= 'M';
  1942.   _NextMonth= 'H';
  1943.   _BeginQuart='Q';
  1944.   _EndQuart  ='U';
  1945.  {$ENDIF}
  1946. begin
  1947.   case Upcase(Key) of                     { Quicken Date Fast Keys }
  1948.     '+'        : Result := D+1;
  1949.     '-'        : Result := D-1;
  1950.     _ToDay     : Result := Date;
  1951.     _PrevYear  : if D <> dateBeginOfYear(D)  then Result:=dateBeginOfYear(D)
  1952.                                              else Result:=dateBeginOfYear(D-1);
  1953.     _NextYear  : if D <> dateEndOfYear(D)    then Result:=dateEndOfYear(D)
  1954.                                              else Result:=dateEndOfYear(Date+1);
  1955.     _PrevMonth : if D <> dateBeginOfMonth(D) then Result:=dateBeginOfMonth(D)
  1956.                                              else Result:=dateBeginOfMonth(D-1);
  1957.     _NextMonth : if D <> dateEndOfMonth(D)   then Result:=dateEndOfMonth(D)
  1958.                                              else Result:=dateEndOfMonth(D+1);
  1959.     _BeginQuart: Result := dateBeginOfQuarter(D);
  1960.     _EndQuart  : Result := dateEndOfQuarter(D);
  1961.     else begin
  1962.       Result := D;
  1963.       exit;
  1964.     end;
  1965.   end;
  1966.   Key:=#0;
  1967. end;
  1968.  
  1969. { time functions }
  1970.  
  1971. function  timeHour(T: TDateTime): Integer;
  1972. var
  1973.   Hour,Minute,Sec,Sec100: Word;
  1974. begin
  1975.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1976.   Result:=Hour;
  1977. end;
  1978.  
  1979. function  timeMin(T: TDateTime): Integer;
  1980. var
  1981.   Hour,Minute,Sec,Sec100: Word;
  1982. begin
  1983.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1984.   Result:=Minute;
  1985. end;
  1986.  
  1987. function  timeSec(T: TDateTime): Integer;
  1988. var
  1989.   Hour,Minute,Sec,Sec100: Word;
  1990. begin
  1991.   DecodeTime(T,Hour,Minute,Sec,Sec100);
  1992.   Result:=Sec;
  1993. end;
  1994.  
  1995. function  timeToInt(T: TDateTime): Integer;
  1996. begin
  1997.   Result:=Trunc((MSecsPerday * T) / 1000);
  1998. end;
  1999.  
  2000. {$IFDEF Win32}
  2001. function  timeZoneOffset: Integer;
  2002. var
  2003.   aTimeZoneInfo : TTimeZoneInformation;
  2004. begin
  2005.   if GetTimeZoneInformation(aTimeZoneInfo)<>-1 then
  2006.      Result := aTimeZoneInfo.Bias
  2007.   else
  2008.      Result := 0;
  2009. end;
  2010. {$ENDIF}
  2011.  
  2012. { Communications Functions }
  2013.  
  2014. function  comIsCis(const S: String): Boolean;
  2015. var
  2016.   aSt: String;
  2017.   PreId,
  2018.   PostId: Integer;
  2019. begin
  2020.   Result:=strContainsU('@compuserve.com',S);     { 28.7.96 sb This is also on CIS }
  2021.   if not Result then
  2022.      if Pos(',',S) > 0 then
  2023.      try
  2024.        aSt:=S;
  2025.        PreId:=StrToInt(strToken(aSt,','));
  2026.        PostId:=StrToInt(aSt);
  2027.        Result:=(PreId > 0) and (PostId > 0);
  2028.      except
  2029.        Result:=False;
  2030.      end;
  2031. end;
  2032.  
  2033. function  comIsInt(const S: String): Boolean;
  2034. var
  2035.   aSt : String;
  2036.   PreId,
  2037.   PostId : String;
  2038. begin
  2039.   try
  2040.     aSt:=S;
  2041.     PreId:=strToken(aSt,'@');
  2042.     PostId:=aSt;
  2043.     Result:=(Length(PreId)>0) and (Length(PostId)>0);
  2044.   except
  2045.     Result:=False;
  2046.   end;
  2047. end;
  2048.  
  2049. { converts a CIS adress to a correct Internet adress }
  2050. function  comCisToInt(const S: String): String;
  2051. var
  2052.   P : Integer;
  2053. begin
  2054.   p:=Pos('INTERNET:',S);
  2055.   if P=1 then
  2056.     Result:=Copy(S,P+1,Length(S))
  2057.   else
  2058.   begin
  2059.     Result:=S;
  2060.     P:=Pos(',',Result);
  2061.     if P>0 then Result[P]:='.';
  2062.     Result:=Result+'@compuserve.com';     { 22.07.96 sb  Error }
  2063.   end;
  2064. end;
  2065.  
  2066. { converts a internet adress to a correct CServe adress }
  2067. function  comIntToCis(const S: String): String;
  2068. var
  2069.   P : Integer;
  2070. begin
  2071.   p:=Pos('@COMPUSERVE.COM',strUpper(S));
  2072.   if p > 0 then
  2073.   begin
  2074.     Result:=strLeft(S,P-1);
  2075.     P:=Pos('.',Result);
  2076.     if P>0 then Result[P]:=',';
  2077.   end else
  2078.     Result:='INTERNET:'+S;
  2079. end;
  2080.  
  2081. { converts a fax adress to a correct CServe adress }
  2082. function  comFaxToCis(const S: String): String;
  2083. begin
  2084.   Result:='FAX:'+S;
  2085. end;
  2086.  
  2087. function comNormFax(const Name, Fax: String): String;
  2088. begin
  2089.   if Name<>'' then
  2090.      Result:=Name+'[fax: '+Name+'@'+strTrim(Fax)+']'
  2091.   else
  2092.      Result:='[fax: '+strTrim(Fax)+']';
  2093. end;
  2094.  
  2095. function  comNormInt(const Name,Int: String): String;
  2096. begin
  2097.   Result:='';
  2098.   if comIsInt(Int) then
  2099.      if Name <> '' then
  2100.         Result := Name + '|smtp: ' + strTrim(Int)
  2101.      else
  2102.         Result := 'smtp: ' + strTrim(Int);
  2103. end;
  2104.  
  2105. function  comNormCis(const Name,Cis: String): String;
  2106. begin
  2107.   Result:='';
  2108.   if Name <> '' then
  2109.      Result := Name + '[compuserve: ' + strTrim(Cis) + ']'
  2110.   else
  2111.      Result := '[compuserve: ' + strTrim(Cis) + ']';
  2112. end;
  2113.  
  2114. function  comNormPhone(const Phone: String): String;
  2115.  
  2116.   function strValueAt(const S:String; At: Integer): String;
  2117.   const
  2118.     Seperator = ',';
  2119.     Str = '"';
  2120.   var
  2121.     j,i: Integer;
  2122.     FSkip : Boolean;
  2123.   begin
  2124.     Result:='';
  2125.     j := 1;
  2126.     i := 0;
  2127.     FSkip:= False;
  2128.     while (i<=At ) and (j<=Length(S)) do
  2129.     begin
  2130.       if (S[j]=Str) then
  2131.          FSkip:=not FSkip
  2132.       else if (S[j]=Seperator) and not FSkip then
  2133.          Inc(i)
  2134.       else if i = At then
  2135.          Result:=Result+S[j];
  2136.       Inc(j);
  2137.     end;
  2138.   end;
  2139.  
  2140. var
  2141.   aNumber,
  2142.   aCountry,
  2143.   aPrefix,
  2144.   aDefault,
  2145.   aLocation  : String;
  2146.  
  2147.   i          : Integer;
  2148. begin
  2149.   aDefault  := '1,"Hamburg","","","40",49,0,0,0,"",1," "';
  2150.   aLocation := strProfile('telephon.ini','Locations','CurrentLocation','');
  2151.   if aLocation <> '' then
  2152.   begin
  2153.     aLocation:=strTokenAt(aLocation,',',0);
  2154.     if aLocation <> '' then
  2155.     begin
  2156.       aLocation:=strProfile('telephon.ini','Locations','Location'+aLocation,'');
  2157.       if aLocation <> '' then
  2158.          aDefault := aLocation;
  2159.     end;
  2160.   end;
  2161.  
  2162.   Result:='';
  2163.   aNumber:=strTrim(Phone);
  2164.   if aNumber <> '' then
  2165.     for i:=Length(aNumber) downto 1 do
  2166.       if not (aNumber[i] in DIGITS) then
  2167.       begin
  2168.         if aNumber[i] <> '+' then aNumber[i] := '-';
  2169.         if i < Length(aNumber) then                    { remove duplicate digits }
  2170.            if aNumber[i]=aNumber[i+1] then
  2171.               Delete(aNumber,i,1);
  2172.       end;
  2173.  
  2174.   if aNumber <> '' then
  2175.   begin
  2176.     if aNumber[1] = '+' then
  2177.        aCountry := strToken(aNumber,'-')
  2178.     else
  2179.        aCountry := '+'+strValueAt(aDefault,5);
  2180.  
  2181.     aNumber:=strTrimChL(aNumber,'-');
  2182.  
  2183.     if aNumber <> '' then
  2184.     begin
  2185.       if strTokenCount(aNumber,'-') > 1 then
  2186.          aPrefix := strTrimChL(strToken(aNumber,'-'),'0')
  2187.       else
  2188.          aPrefix := strValueAt(aDefault,4);
  2189.  
  2190.       aNumber:= strNicePhone(strTrimChA(aNumber,'-'));
  2191.       Result := aCountry + ' ('+aPrefix+') '+aNumber;
  2192.     end;
  2193.   end;
  2194. end;
  2195.  
  2196. { system functions }
  2197.  
  2198. {$IFDEF Win32}
  2199. function sysTempPath: String;
  2200. var
  2201.   Buffer: array[0..1023] of Char;
  2202. begin
  2203.   SetString(Result, Buffer, GetTempPath(Sizeof(Buffer)-1,Buffer));
  2204. end;
  2205. {$ELSE}
  2206. function sysTempPath:String;
  2207. var
  2208.   Buffer: array[0..255] of char;
  2209. begin
  2210.   GetTempFileName(#0,'TMP',0,Buffer);             { 15.07.96 sb }
  2211.   Result:=StrPas(Buffer);
  2212.   DeleteFile(Result);
  2213.   Result:=ExtractFilePath(Result);
  2214. end;
  2215. {$ENDIF}
  2216.  
  2217. procedure sysDelay(aMs: Longint);
  2218. var
  2219.   TickCount       : LongInt;
  2220. begin
  2221.   TickCount:=GetTickCount;
  2222.   while GetTickCount - TickCount < aMs do Application.ProcessMessages;
  2223. end;
  2224.  
  2225. procedure sysBeep;
  2226. begin
  2227.   messageBeep($FFFF);
  2228. end;
  2229.  
  2230. function sysColorDepth: Integer;
  2231. var
  2232.   aDC: hDC;
  2233. begin
  2234.   Result:=0;
  2235.   try
  2236.     aDC := GetDC(0);
  2237.     Result:=1 shl (GetDeviceCaps(aDC,PLANES) * GetDeviceCaps(aDC, BITSPIXEL));
  2238.   finally
  2239.     ReleaseDC(0,aDC);
  2240.   end;
  2241. end;
  2242.  
  2243. {$IFDEF Win32}
  2244. procedure sysSaverRunning(Active: Boolean);
  2245. var
  2246.   aParam: Longint;
  2247. begin
  2248.   SystemParametersInfo (SPI_SCREENSAVERRUNNING, Word(Active),@aParam,0);
  2249. end;
  2250. {$ENDIF}
  2251.  
  2252. { registry functions }
  2253.  
  2254. {$IFDEF Win32 }
  2255.  
  2256. procedure regParsePath(const Path: String; var aPath, aValue: String);
  2257. begin
  2258.   aPath:=Path;
  2259.   aValue:= '';
  2260.   while (Length(aPath)>0) and (strLastCh(aPath)<>'\') do
  2261.   begin
  2262.     aValue:=strLastCh(aPath)+aValue;
  2263.     strStripLast(aPath);
  2264.   end;
  2265. end;
  2266.  
  2267. function regReadString(aKey: HKEY; const Path: String): String;
  2268. var
  2269.   aRegistry : TRegistry;
  2270.   aPath     : String;
  2271.   aValue    : String;
  2272. begin
  2273.   aRegistry:=TRegistry.Create;
  2274.   try
  2275.     with aRegistry do
  2276.     begin
  2277.       RootKey:=aKey;
  2278.       regParsePath(Path, aPath, aValue);
  2279.       OpenKey(aPath,True);
  2280.       Result:=ReadString(aValue);
  2281.     end;
  2282.   finally
  2283.     aRegistry.Free;
  2284.   end;
  2285. end;
  2286.  
  2287. procedure regWriteString(aKey: HKEY; const Path,Value: String);
  2288. var
  2289.   aRegistry : TRegistry;
  2290.   aPath     : String;
  2291.   aValue    : String;
  2292. begin
  2293.   aRegistry:=TRegistry.Create;
  2294.   try
  2295.     with aRegistry do
  2296.     begin
  2297.       RootKey:=aKey;
  2298.       regParsePath(Path, aPath, aValue);
  2299.       OpenKey(aPath,True);
  2300.       WriteString(aValue,Value);
  2301.     end;
  2302.   finally
  2303.     aRegistry.Free;
  2304.   end;
  2305. end;
  2306.  
  2307. procedure regDelValue(aKey: hKey; const Path: String);
  2308. var
  2309.   aRegistry : TRegistry;
  2310.   aPath     : String;
  2311.   aValue    : String;
  2312. begin
  2313.   aRegistry:=TRegistry.Create;
  2314.   try
  2315.     with aRegistry do
  2316.     begin
  2317.       RootKey:=aKey;
  2318.       regParsePath(Path, aPath, aValue);
  2319.       OpenKey(aPath,True);
  2320.       DeleteValue(aValue);
  2321.     end;
  2322.   finally
  2323.     aRegistry.Free;
  2324.   end;
  2325. end;
  2326.  
  2327. (*!!!
  2328. function regReadString(aKey: hKey; const Value: String): String;
  2329. var
  2330.   aTmp  : array[0..255] of char;
  2331.   aCb,
  2332.   aType : Integer;
  2333. begin
  2334.   Result:='';
  2335.   if aKey<> 0 then
  2336.   begin
  2337.     aCb:=Sizeof(aTmp)-1;
  2338.    { aData:=@aTmp; }
  2339.     if RegQueryValueEx(aKey,PChar(Value),nil,@aType,@aTmp,@aCb)=ERROR_SUCCESS then
  2340.        if aType=REG_SZ then Result:=String(aTmp);
  2341.   end;
  2342. end; *)
  2343.  
  2344. function regInfoString(const Value: String): String;
  2345. var
  2346.   aKey : hKey;
  2347. begin
  2348.   Result:='';
  2349.   if RegOpenKey(HKEY_LOCAL_MACHINE,REG_CURRENT_VERSION,aKey)=ERROR_SUCCESS then
  2350.   begin
  2351.     Result:=regReadString(aKey,Value);
  2352.     RegCloseKey(aKey);
  2353.   end;
  2354. end;
  2355.  
  2356. function regCurrentUser: String;
  2357. begin
  2358.   Result:=regInfoString(REG_CURRENT_USER);
  2359. end;
  2360.  
  2361. function regCurrentCompany: String;
  2362. begin
  2363.   Result:=regInfoString(REG_CURRENT_COMPANY);
  2364. end;
  2365.  
  2366. { Add a shell extension to the registry }
  2367. procedure regWriteShellExt(const aExt,aCmd,aMenu,aExec: String);
  2368. var
  2369.   s, aPath : String;
  2370. begin
  2371.   with TRegistry.Create do
  2372.   try
  2373.     RootKey := HKEY_CLASSES_ROOT;
  2374.     aPath   := aExt;
  2375.     if KeyExists(aPath) then
  2376.     begin
  2377.       OpenKey(aPath,False);
  2378.       S:=ReadString('');
  2379.       CloseKey;
  2380.       if S<>'' then
  2381.          if KeyExists(S) then
  2382.             aPath:=S;
  2383.     end;
  2384.  
  2385.     OpenKey(aPath+'\Shell\'+aCmd,True);
  2386.     WriteString('',aMenu);
  2387.     CloseKey;
  2388.  
  2389.     OpenKey(aPath+'\Shell\'+aCmd+'\Command',True);
  2390.     WriteString('',aExec + ' %1');
  2391.     CloseKey;
  2392.   finally
  2393.     Free;
  2394.   end;
  2395. end;
  2396.  
  2397. procedure regValueList(aKey: HKEY; const Path:String; var aValue: TStringList);
  2398. var
  2399.   aRegistry: TRegistry;
  2400. begin
  2401.   aRegistry:=TRegistry.Create;
  2402.   try
  2403.     with aRegistry do
  2404.     begin
  2405.       RootKey:=aKey;
  2406.       OpenKey(Path,True);
  2407.       GetValueNames(aValue);
  2408.     end;
  2409.   finally
  2410.     aRegistry.Free;
  2411.   end;
  2412. end;
  2413.  
  2414. procedure regKeyList(aKey: HKEY; const Path:String; var aValue: TStringList);
  2415. var
  2416.   aRegistry: TRegistry;
  2417. begin
  2418.   aRegistry:=TRegistry.Create;
  2419.   try
  2420.     with aRegistry do
  2421.     begin
  2422.       RootKey:=aKey;
  2423.       OpenKey(Path,True);
  2424.       GetKeyNames(aValue);
  2425.     end;
  2426.   finally
  2427.     aRegistry.Free;
  2428.   end;
  2429. end;
  2430.  
  2431. function regValueExist(aKey: HKEY; const Path:String):Boolean;
  2432. var
  2433.   aRegistry: TRegistry;
  2434.   aPath: String;
  2435.   aValue: String;
  2436. begin
  2437.   aRegistry:=TRegistry.Create;
  2438.   try
  2439.     with aRegistry do
  2440.     begin
  2441.       RootKey:=aKey;
  2442.       regParsePath(Path, aPath, aValue);
  2443.       OpenKey(aPath,True);
  2444.       Result := ValueExists(aValue)
  2445.     end;
  2446.   finally
  2447.     aRegistry.Free;
  2448.   end;
  2449. end;
  2450.  
  2451. function  regReadValue(aKey:HKEY; const Path:String; Typ: TDataType): Variant;
  2452. var
  2453.   aRegistry: TRegistry;
  2454.   aPath: String;
  2455.   aValue: String;
  2456. begin
  2457.   aRegistry:=TRegistry.Create;
  2458.   try
  2459.     with aRegistry do
  2460.     begin
  2461.       RootKey:=aKey;
  2462.       regParsePath(Path, aPath, aValue);
  2463.       if OpenKey(aPath,True) then
  2464.         if ValueExists(aValue) then
  2465.            case Typ of
  2466.              dtInteger:  Result := ReadInteger(aValue);
  2467.              dtBoolean:  Result := ReadBool(aValue);
  2468.              dtString:   Result := ReadString(aValue);
  2469.              dtDate:     Result := ReadDate(aValue);
  2470.              dtFloat:    Result := ReadFloat(aValue);
  2471.              dtCurrency: Result := ReadCurrency(aValue);
  2472.              dtTime:     Result := REadTime(aValue);
  2473.            end;
  2474.     end;
  2475.   finally
  2476.     aRegistry.Free;
  2477.   end;
  2478. end;
  2479.  
  2480. function  regWriteValue(aKey: HKEY; const Path: String; Value: Variant; Typ: TDataType): Boolean;
  2481. var
  2482.   aRegistry : TRegistry;
  2483.   aPath     : String;
  2484.   aValue    : String;
  2485. begin
  2486.   aRegistry:=TRegistry.Create;
  2487.   try
  2488.     with aRegistry do
  2489.     begin
  2490.       RootKey:=aKey;
  2491.       regParsePath(Path, aPath, aValue);
  2492.       if OpenKey(aPath,True) then
  2493.         case Typ of
  2494.           dtInteger:  WriteInteger(aValue, Value);
  2495.           dtBoolean:  WriteBool(aValue, Value);
  2496.           dtString:   WriteString(aValue, Value);
  2497.           dtDate:     WriteDate(aValue, Value);
  2498.           dtFloat:    WriteFloat(aValue, Value);
  2499.           dtCurrency: WriteCurrency(aValue, Value);
  2500.           dtTime:     WriteTime(aValue, Value);
  2501.         end
  2502.       else
  2503.         Result := False;
  2504.     end;
  2505.   finally
  2506.     aRegistry.Free;
  2507.   end;
  2508. end;
  2509.  
  2510. {$ENDIF}
  2511.  
  2512. { other stuff }
  2513.  
  2514. function MsgBox(const aTitle,aMsg: String; aFlag: Integer): Integer;
  2515. var
  2516.   ActiveWindow : hWnd;
  2517.   WindowList   : Pointer;
  2518.   TmpA         : array[0..200] of char;
  2519.   TmpB         : array[0..100] of char;
  2520. begin
  2521.   ActiveWindow:=GetActiveWindow;
  2522.   WindowList:= DisableTaskWindows(0);
  2523.   try
  2524.     StrPCopy(TmpB,aTitle);
  2525.     StrPCopy(TmpA,aMsg);
  2526.    {$IFDEF Win32}
  2527.     Result:=Windows.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  2528.    {$ELSE}
  2529.     Result:=WinProcs.MessageBox(Application.Handle, TmpA, TmpB, aFlag);
  2530.    {$ENDIF}
  2531.   finally
  2532.     EnableTaskWindows(WindowList);
  2533.     SetActiveWindow(ActiveWindow);
  2534.   end;
  2535. end;
  2536.  
  2537. function Question(const Msg: String):Boolean;
  2538. begin
  2539.   if IsWin95 or IsWinNT then
  2540.     Result:=MsgBox(LoadStr(SMsgdlgConfirm),Msg, MB_ICONQUESTION or MB_YESNO)=IDYES
  2541.   else
  2542.     Result:=messageDlg(Msg,mtConfirmation,[mbYes,mbNo],0)=mrYes;
  2543. end;
  2544.  
  2545. procedure Information(const Msg: String);
  2546. begin
  2547.   if IsWin95 or IsWinNT then
  2548.      MsgBox(LoadStr(SMsgdlgInformation), Msg, MB_ICONINFORMATION or MB_OK )
  2549.   else
  2550.      messageDlg(Msg,mtInformation,[mbOk],0);
  2551. end;
  2552.  
  2553. function Confirmation(const Msg: String): Word;
  2554. begin
  2555.   if IsWin95 or IsWinNT then
  2556.      case MsgBox(LoadStr(SMsgDlgConfirm),Msg,MB_ICONQUESTION or MB_YESNOCANCEL) of
  2557.        IDYES    : Result := mrYes;
  2558.        IDNO     : Result := mrNo;
  2559.        IDCANCEL : Result := mrCancel;
  2560.        else       Result := mrCancel;
  2561.      end
  2562.   else
  2563.      Result:=MessageDlg(Msg,mtConfirmation,[mbYes,mbNo,mbCancel],0);
  2564. end;
  2565.  
  2566. { TPersistentRect }
  2567.  
  2568. constructor TPersistentRect.Create;
  2569. begin
  2570.   FRect:=rectSet(10,10,100,20);
  2571. end;
  2572.  
  2573. procedure TPersistentRect.Assign(Source: TPersistent);
  2574. var
  2575.  Value: TPersistentRect;
  2576. begin
  2577.   if Value is TPersistentRect then
  2578.   begin
  2579.     Value:=Source as TPersistentRect;
  2580.     FRect:=rectBounds(Value.Left,Value.Top,Value.Width,Value.Height);
  2581.     exit;
  2582.   end;
  2583.   inherited Assign(Source);
  2584. end;
  2585.  
  2586. procedure TPersistentRect.SetLeft(Value: Integer);
  2587. begin
  2588.   if Value<>Left then
  2589.   begin
  2590.     if Assigned(FOnConvert) then
  2591.        Value:=FOnConvert(Self,Value,False);
  2592.     FRect:=rectBounds(Value,Top,Width,Height);
  2593.   end;
  2594. end;
  2595.  
  2596. procedure TPersistentRect.SetTop(Value: Integer);
  2597. begin
  2598.   if Value<>Top then
  2599.   begin
  2600.     if Assigned(FOnConvert) then
  2601.        Value:=FOnConvert(Self,Value,False);
  2602.     FRect:=rectBounds(Left,Value,Width,Height);
  2603.   end;
  2604. end;
  2605.  
  2606. procedure TPersistentRect.SetHeight(Value: Integer);
  2607. begin
  2608.   if Value<>Height then
  2609.   begin
  2610.     if Assigned(FOnConvert) then
  2611.        Value:=FOnConvert(Self,Value,False);
  2612.     FRect:=rectBounds(Left,Top,Width,Value);
  2613.   end;
  2614. end;
  2615.  
  2616. procedure TPersistentRect.SetWidth(Value: Integer);
  2617. begin
  2618.   if Value<>Width then
  2619.   begin
  2620.     if Assigned(FOnConvert) then
  2621.        Value:=FOnConvert(Self,Value,False);
  2622.     FRect:=rectBounds(Left,Top,Value,Height);
  2623.   end;
  2624. end;
  2625.  
  2626. function  TPersistentRect.GetLeft: Integer;
  2627. begin
  2628.   Result:=FRect.Left;
  2629.   if Assigned(FOnConvert) then
  2630.      Result:=FOnConvert(Self,Result,True);
  2631. end;
  2632.  
  2633. function  TPersistentRect.GetTop: Integer;
  2634. begin
  2635.   Result:=FRect.Top;
  2636.   if Assigned(FOnConvert) then
  2637.      Result:=FOnConvert(Self,Result,True);
  2638. end;
  2639.  
  2640. function  TPersistentRect.GetHeight: Integer;
  2641. begin
  2642.   Result:=rectHeight(FRect);
  2643.   if Assigned(FOnConvert) then
  2644.      Result:=FOnConvert(Self,Result,True);
  2645. end;
  2646.  
  2647. function  TPersistentRect.GetWidth: Integer;
  2648. begin
  2649.   Result:=rectWidth(FRect);
  2650.   if Assigned(FOnConvert) then
  2651.      Result:=FOnConvert(Self,Result,True);
  2652. end;
  2653.  
  2654. {$IFDEF Win32}
  2655.  
  2656. { TPersistentRegistry }
  2657.  
  2658. function TPersistentRegistry.ReadComponent(const Name: String;
  2659.                                  Owner, Parent: TComponent): TComponent;
  2660. var
  2661.   DataSize  : Integer;
  2662.   MemStream : TMemoryStream;
  2663.   Reader    : TReader;
  2664. begin
  2665.   Result := nil;
  2666.   DataSize:=GetDataSize(Name);
  2667.   MemStream := TMemoryStream.Create;
  2668.   try
  2669.     MemStream.SetSize(DataSize);
  2670.     ReadBinaryData(Name,MemStream.Memory^,DataSize);
  2671.     MemStream.Position := 0;
  2672.  
  2673.     Reader := TReader.Create(MemStream, 256);
  2674.     try
  2675.       Reader.Parent := Parent;
  2676.       Result := Reader.ReadRootComponent(nil);
  2677.       if Owner <> nil then
  2678.         try
  2679.           Owner.InsertComponent(Result);
  2680.         except
  2681.           Result.Free;
  2682.           raise;
  2683.         end;
  2684.     finally
  2685.       Reader.Free;
  2686.     end;
  2687.  
  2688.   finally
  2689.     MemStream.Free;
  2690.   end;
  2691. end;
  2692.  
  2693. procedure TPersistentRegistry.WriteComponent(const Name: String; Component: TComponent);
  2694. var
  2695.   MemStream: TMemoryStream;
  2696. begin
  2697.   MemStream := TMemoryStream.Create;
  2698.   try
  2699.     MemStream.WriteComponent(Component);
  2700.     WriteBinaryData(Name, MemStream.Memory^, MemStream.Size);
  2701.   finally
  2702.     MemStream.Free;
  2703.   end;
  2704. end;
  2705.  
  2706. {$ENDIF}
  2707.  
  2708. { TSystemMetric }
  2709.  
  2710. constructor TSystemMetric.Create;
  2711. begin
  2712.   inherited Create;
  2713.   Update;
  2714. end;
  2715.  
  2716. procedure TSystemMetric.Update;
  2717.  
  2718.   function GetSystemPoint(ax,ay: Integer):TPoint;
  2719.   begin
  2720.     Result:=Point(GetSystemMetrics(ax),GetSystemMetrics(ay));
  2721.   end;
  2722.  
  2723. begin
  2724.   FMenuHeight    :=GetSystemMetrics(SM_CYMENU);
  2725.   FCaptionHeight :=GetSystemMetrics(SM_CYCAPTION);
  2726.   FBorder        :=GetSystemPoint(SM_CXBORDER,SM_CYBORDER);
  2727.   FFrame         :=GetSystemPoint(SM_CXFRAME,SM_CYFRAME);
  2728.   FDlgFrame      :=GetSystemPoint(SM_CXDLGFRAME,SM_CYDLGFRAME);
  2729.   FBitmap        :=GetSystemPoint(SM_CXSIZE,SM_CYSIZE);
  2730.   FHScroll       :=GetSystemPoint(SM_CXHSCROLL,SM_CYHSCROLL);
  2731.   FVScroll       :=GetSystemPoint(SM_CXVSCROLL,SM_CYVSCROLL);
  2732.   FThumb         :=GetSystemPoint(SM_CXHTHUMB,SM_CYVTHUMB);
  2733.   FFullScreen    :=GetSystemPoint(SM_CXFULLSCREEN,SM_CYFULLSCREEN);
  2734.   FMin           :=GetSystemPoint(SM_CXMIN,SM_CYMIN);
  2735.   FMinTrack      :=GetSystemPoint(SM_CXMINTRACK,SM_CYMINTRACK);
  2736.   FCursor        :=GetSystemPoint(SM_CXCURSOR,SM_CYCURSOR);
  2737.   FIcon          :=GetSystemPoint(SM_CXICON,SM_CYICON);
  2738.   FDoubleClick   :=GetSystemPoint(SM_CXDOUBLECLK,SM_CYDOUBLECLK);
  2739.   FIconSpacing   :=GetSystemPoint(SM_CXICONSPACING,SM_CYICONSPACING);
  2740.   FColorDepth    :=sysColorDepth;
  2741. end;
  2742.  
  2743. { TDesktopCanvas }
  2744.  
  2745. constructor TDesktopCanvas.Create;
  2746. begin
  2747.   inherited Create;
  2748.   DC:=GetDC(0);
  2749.   Handle:=DC;
  2750. end;
  2751.  
  2752. destructor  TDesktopCanvas.Destroy;
  2753. begin
  2754.   Handle:=0;
  2755.   ReleaseDC(0, DC);
  2756.   inherited Destroy;
  2757. end;
  2758.  
  2759. {$IFNDEF Win32}
  2760.  
  2761. procedure DoneXProcs; far;
  2762. begin
  2763.   SysMetric.Free;
  2764. end;
  2765.  
  2766. {$ENDIF}
  2767.  
  2768. {$IFDEF Win32}
  2769. function CheckNT: Boolean;
  2770. var
  2771.   aVersion: TOSVersionInfo;
  2772. begin
  2773.   aVersion.dwOSVersionInfoSize:= SizeOf(aVersion);
  2774.   Result:= GetVersionEx(aVersion) and (aVersion.dwPLatformId = VER_PLATFORM_WIN32_NT);
  2775. end;
  2776. {$ENDIF}
  2777.  
  2778. initialization
  2779.   Randomize;
  2780.  
  2781.   SysMetric := TSystemMetric.Create;
  2782.   IsWin95   := (GetVersion and $FF00) >= $5F00;
  2783.  {$IFDEF Win32}
  2784.   IsWinNT   := CheckNT;
  2785.  {$ELSE}
  2786.   IsWinNT   := False;
  2787.  {$ENDIF}
  2788.  
  2789.   IsFabula  := nil;
  2790.  
  2791. {$IFDEF Win32}
  2792.   xLanguage := (LoWord(GetUserDefaultLangID) and $3ff);
  2793.   case xLanguage of
  2794.     LANG_GERMAN    : xLangOfs := 70000;
  2795.     LANG_ENGLISH   : xLangOfs := 71000;
  2796.     LANG_SPANISH   : xLangOfs := 72000;
  2797.     LANG_RUSSIAN   : xLangOfs := 73000;
  2798.     LANG_ITALIAN   : xLangOfs := 74000;
  2799.     LANG_FRENCH    : xLangOfs := 75000;
  2800.     LANG_PORTUGUESE: xLangOfs := 76000;
  2801.     else             xLangOfs := 71000;
  2802.   end;
  2803. {$ENDIF}
  2804.  
  2805. {$IFDEF Win32}
  2806. finalization
  2807.   SysMetric.Free;
  2808. {$ELSE}
  2809.   AddExitProc(DoneXProcs);
  2810. {$ENDIF}
  2811. end.
  2812.  
  2813.  
  2814.  
  2815.  
  2816.