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