home *** CD-ROM | disk | FTP | other *** search
/ Chip 2002 November / Chip_2002-11_cd1.bin / zkuste / delphi / unity / d3456 / JBSTR.ZIP / jbstr.pas < prev    next >
Pascal/Delphi Source File  |  2002-07-10  |  41KB  |  1,558 lines

  1. {.$D-,L-}
  2. Unit jbStr;
  3. Interface
  4. {
  5.  Basic Operation for string manipulation
  6.  (c) 1991-2002 J.BENES, All right reserved
  7.  E-mail: micrel@micrel.cz
  8.  WWW home: http://www.micrel.cz/delphi/
  9.  
  10. Actualization:
  11. --------------
  12. 09.7.2002 Fixbug FORM function (Real number formatting)
  13. 21.3.2002 New actualization of source
  14. 21.1.2001 New acualize of source
  15. 28.8.2000 FixBug on all LongStrings
  16. 27.8.2000 Fixbug in Form funcion
  17. }
  18. {$IfDef Win32}
  19. {$LONGSTRINGS ON}
  20. {$DEFINE HStrings}
  21. {$Else}
  22. {.$LONGSTRINGS OFF}
  23. {$EndIf}
  24. Type
  25.   CharSet = Set Of Char;
  26.   TSTRLen = {$IfNDef HStrings}Byte{$Else}Integer{$EndIf};
  27.  
  28. Function  Version:Word;
  29. Function  Reduce(Const S:String;AboutSize:Integer):String;
  30. Function  JoinTo(PreStr,Delim,PostStr:String):String;
  31. Function  Alter(Str,AlterStr:String):String;
  32. Function  AlterTo(Str,CondicStr,AlterStr:String):String;
  33. Function  UpCase(CH:Char):Char;
  34. Function  LoCase(CH:Char):Char;
  35. Function  StrLoCase(S:String):String;
  36. Function  StrUpCase(S:String):String;
  37. Function  StrUpCaseNoCs(S:String):String;
  38. Function  CharStr(CH:Char;Len:TStrLen):String;
  39. Function  StrStr(Const S:String;krat:TStrLen):String;
  40. Function  PadCh(S:String;CH:Char;Len:TStrLen):String;
  41. Function  Pad(Const S:String;Len:TStrLen):String;
  42. Function  LeftPadCh(S:String;CH:Char;Len:TStrLen):String;
  43. Function  LeftPad(Const S:String;Len:TStrLen):String;
  44. Procedure Null(Var S:String);
  45. Function  Hash(Const S:String):LongInt;
  46. Function  Space(B:TStrLen):String;
  47. Function  MakeStr(Const S:String;B:TStrLen):String;{alias charstr}
  48. Function  TrimLead(Const S:String):String;
  49. Function  TrimTrail(Const S:String):String;
  50. Function  Trim(Const S:String):String;
  51. Function  ZeroClip(Const S:String):String;
  52. Function  CapitalizeWord(Const S:String):String;
  53. Function  CenterCh(Const S:String;CH:Char;Width:TStrLen):String;
  54. Function  Center(Const S:String;Width:TStrLen):String;
  55. Function  WordCount(S:String;WordDelims:CharSet):TStrLen;
  56. Function  ExtractWord(N:TStrLen;S:String;WordDelims:CharSet):String;
  57. Function  FindWord(what,S:String;WordDelims:CharSet):Boolean;
  58. Function  GetFirstWord(Const S:String;WordDelims:CharSet):String;
  59. Function  GetLastWord(Const S:String;WordDelims:CharSet):String;
  60. Function  ChangeWord(N:TStrLen;Const Wrd,S:String;WordDelims:CharSet):String;
  61. Procedure WordWrap(InSt:String;Var OutSt,Overlap:String;
  62.                    Margin:TStrLen;PadToMargin:Boolean);
  63. Function  PopWord(B:TStrLen;Var S:String;WordDelims:CharSet):String;
  64. Function  GetPos(B:TStrLen;S:String;WordDelims:CharSet):TStrLen;
  65. Function  GetEnd(B:TStrLen;S:String;WordDelims:CharSet):TStrLen;
  66. Function  InsWord(iWord,cWord,cString:String):String;
  67. Function  Smash(C:Char;Const S:String):String;
  68. Function  Mask(CharOfMask:Char;Const StrMask,Matrice:String;
  69.                Var NextPosic:TStrLen):String;
  70. Function  Count(CH:Char;Const Dest:String;Var Posic,Len:TStrLen):Boolean;
  71. Function  Push(Posic:TStrLen;Const Source,Dest:String):String;
  72. Procedure Flop(Var S1,S2:String);
  73. Function  Strip(Const Mask,Source:String):String;
  74. Function  Change(S:String;Source,Dest:Char):String;
  75. Function  ChangeTo(S:String;Source:CharSet;Dest:Char):String;
  76. Function  ChangeXChars(FindChar,DestChar:Char;Const Source:String):String;
  77. Function  Zip(Const Mask,Source:String):String;
  78. Function  Turn(Const S:String):String;
  79. Function  Entab(Const Sx:String;TabSize:TStrLen):String;
  80. Function  Detab(Const Sx:String;TabSize:TStrLen):String;
  81. Function  HasExtension(Const Name:String; Var DotPos:Word):Boolean;
  82. Function  DefaultExtension(Const Name, Ext:String):String;
  83. Function  ForceExtension(Const Name, Ext:String):String;
  84. Function  JustExtension(Const PathName:String):String;
  85. Function  JustFilename(Const PathName:String):String;
  86. Function  JustPathname(Const PathName:String):String;
  87. Function  AddLastChar(C:Char;Const DirName:String):String;
  88. Function  RemLastChar(Const DirName:String):String;
  89. Function  CleanDOSFileName(FileName:String):String;
  90. Function  TestFileName(FName:String):Boolean;
  91. Function  ShortDirName (Len:TStrLen; Const PName:String):String ;
  92. Function  ShortFileName(Len:TStrLen;Const FName:String):String;
  93. Function  JustName(Const PathName:String):String;
  94. Function  Mult(Const S:String):TStrLen;
  95. Function  Num(Const S:String;Soustava:Byte):LongInt;
  96. Function  Doc(L:LongInt;Const Soustava:Byte):String;
  97. Function  PackNum(Const S:String):String;
  98. Function  UnpackNum(Const S:String):String;
  99. Function  Str3Long(Const S:String):LongInt;
  100. Function  Str2Long(Const S:String; Var I:LongInt):Boolean;
  101. Function  Str2Word(Const S:String; Var I:Word):Boolean;
  102. Function  Str2Int(Const S:String; Var I:SmallInt):Boolean;
  103. Function  Str2Real(Const S:String; Var R:Real):Boolean;
  104. Function  Long2Str(L:LongInt):String;
  105. Function  Real2Str(R:Real; Width, Places:Byte):String;
  106. Function  Form(Const Mask:String; R:Real):String;
  107. Function  StripChars(S:String;ch:CharSet):String;
  108.  
  109. {Czech code page definition}
  110. Const
  111.   swKamenic   = 0; {cestina Kamenickych}
  112.   swWin31CE   = 1; {cestina Windows 3.1 CE}
  113.   swWin1250   = 2; {cestina Windows page 1250}
  114.   swECMA      = 3; {kodovani ECMA ansi}
  115.   swLatin2    = 4; {kodovani Latin 2}
  116.   swUsaAnsi   = 5; {cesky jen dle generatoru}
  117.   swIbm       = 6; {bez vsech hacku a carek}
  118.   swSemigraph = 7; {jako ibm ale bez jakekoliv grafiky}
  119.   swMacIntosh = 8; {kodovani pro mac}
  120.  
  121. Function  Trans(St:String;odkud,kampak:Byte):String;
  122. Function  Roman2Int(Const S: String): LongInt;
  123. Function  Int2Roman(Value: Longint): String;
  124.  
  125. Function  ExtractNumber(Const S:String):String;
  126. Function  ExtractAlphas(Const S:String):String;
  127. Function  ExtractAlphaNum(Const S:String):String;
  128. Function  ExtractChars(Const S:String;chars:CharSet):String;
  129.  
  130. Const
  131.   MaskZipChar:Char = 'X';
  132.  
  133. Function htmlSrcEmail(Const S:String):String;
  134.  
  135. Function SetBit(Num,B:Byte):Byte;
  136. Function IsSetBit(Num,B:Byte):Boolean;
  137. Function ReSetBit(Num,B:Byte):Byte;
  138. Function SetToggle(Num,B:Byte):Byte;
  139.  
  140. Const
  141.   ccYes:String = '1';
  142.   ccNo:String = '0';
  143. Function YesOrNo(B:Boolean):String;
  144. Function YesOrNoEx(B:Boolean;Const StrYes,StrNo:String):String;
  145. Function TestTo(S:String;SArr: Array of String):Boolean;
  146. Function TestBeginTo(S:String;SArr: Array of String):Boolean;
  147.  
  148. Const
  149.   ccCrLf = #13#10;
  150.   ccCr = #10;
  151.  
  152. function PosN(Substring,Mainstring:string;occurrence:integer):integer;
  153.  
  154. Implementation
  155.  
  156. {cislo verse unity lo = verze; hi = subverze}
  157. Function Version;
  158. Begin Version := 2 + 256 * 28; {tj. verze 2.28 Delphi} End;
  159.  
  160. Const
  161.   MaxCnt = 22;          {kod Windows}
  162.   LoCharCS: String [MaxCnt] = 'ⁿΘ∩ΣΦ∞σ╛₧⌠÷∙²¥ßφ≤·≥Ü°α';
  163.   HiCharCS: String [MaxCnt] = '▄╔╧─╚╠┼╝Ä╘╓┘▌ì┴═╙┌╥è╪└';
  164.   NoCharCS: String [MaxCnt] = 'UEDACELLZOOUYTAIOUNSRR';
  165.  
  166. Function UpCase;
  167.   {-prevede mala pismena na velka, pouze kod Latin2}
  168. Begin
  169.   If Pos(CH,LoCharCS) <> 0 Then Begin
  170.     UpCase := HiCharCS[Pos(CH,LoCharCS)];
  171.     Exit
  172.   End;
  173.   If CH In ['a'..'z'] Then UpCase := Char(Byte(CH) And $DF)
  174.   Else UpCase := CH;
  175. End;
  176.  
  177. Function Reduce(Const S:String;AboutSize:Integer):String;
  178.  {-zkrati retezec o urcitou delku}
  179. Begin
  180.   Result:=Copy(S,1,Length(S)-AboutSize)
  181. End;
  182.  
  183. Function JoinTo(PreStr,Delim,PostStr:String):String;
  184.  {-spoji 2 retezce pomoci oddelovace}
  185. Begin
  186.   If PreStr='' Then Result:=PostStr
  187.   Else
  188.     If PostStr='' Then Result:=PreStr
  189.     Else Result:=PreStr+Delim+PostStr;
  190. End;
  191.  
  192. Function  Alter(Str,AlterStr:String):String;
  193.  {-alternativni plneni retezce}
  194. Begin
  195.   If Str='' Then Result:=AlterStr
  196.   Else Result:=Str;
  197. End;
  198.  
  199. Function AlterTo(Str,CondicStr,AlterStr:String):String;
  200.   {-alternativni plneni retezce s podminkou}
  201. Begin
  202.   If Str = CondicStr Then Result := AlterStr
  203.   Else Result := Str;
  204. End;
  205.  
  206. Function LoCase;
  207.   {-prevede velka pismena na mala}
  208. Begin
  209.   If Pos(CH,HiCharCS) <> 0 Then Begin
  210.     LoCase := LoCharCS[Pos(CH,HiCharCS)];
  211.     Exit
  212.   End;
  213.   If CH In ['A'..'Z'] Then LoCase := Char(Byte(CH) Or $20)
  214.   Else LoCase := CH;
  215. End;
  216.  
  217. Function StrLoCase;
  218.   {-v celem retezci prevede velka pismena na mala}
  219. Var I:Word;
  220. Begin
  221.   Result := S;
  222.   If Result = '' Then Exit;
  223.   For I := 1 To Length(Result) Do Result[I] := LoCase(Result[I]);
  224. End;
  225.  
  226. Function StrUpCase;
  227.   {-v celem retezci prevede mala pismena na velka}
  228. Var I:Integer;
  229. Begin
  230.   StrUpCase := '';
  231.   If S = '' Then Exit;
  232.   For I := 1 To Length(S) Do S[I] := UpCase(S[I]);
  233.   StrUpCase := S;
  234. End;
  235.  
  236. Function StrUpCaseNoCs;
  237.   {-v celem retezci prevede mala pismena na velka a odstrani ceske znaky}
  238. Var I:Integer;
  239. Begin
  240.   StrUpCaseNoCs := '';
  241.   If S = '' Then Exit;
  242.   For I := 1 To Length(S) Do Begin
  243.     S[I] := UpCase(S[I]);
  244.     If Pos(S[I],HiCharCs) <> 0 Then S[I] := NoCharCs[Pos(S[I],HiCharCs)];
  245.   End;
  246.   StrUpCaseNoCs := S;
  247. End;
  248.  
  249. Function CharStr;
  250.   {-vyrobi novy retezec vyplneny znaky C}
  251. Var
  252.   I:Integer;
  253. Begin
  254.   Result := '';
  255.   If Len > 0 Then For I:= 1 To Len Do Result := Result + CH;
  256. End;
  257.  
  258. Function  StrStr;
  259. Var
  260.   I:Integer;
  261. Begin
  262.   Result := '';
  263.   For I := 1 To krat Do Result := Result + S;
  264. End;
  265.  
  266. Function PadCh;
  267.   {-vraci zprava znakem ch zarovnany retezec v delce len}
  268. Var
  269.   I:Integer;
  270. Begin
  271.   Result := S;
  272.   If Length(S) < Len Then For I := Length(S)+1 To Len Do Result := Result + CH
  273. End;
  274.  
  275. Function Pad;
  276.   {-vraci zprava mezerami zarovnany retezec v delce len}
  277. Begin
  278.   Pad := PadCh(S, ' ', Len);
  279. End;
  280.  
  281. Function LeftPadCh;
  282.   {-vraci zleva znakem ch zarovnany retezec v delce len}
  283. Var
  284.   I:Integer;
  285. Begin
  286.   Result := S;
  287.   If Length(S) < Len Then For I := Length(S)+1 To Len Do Result := CH + Result
  288. End;
  289.  
  290. Function LeftPad;
  291.   {-vraci zleva mezerami zarovnany retezec v delce len}
  292. Begin
  293.   LeftPad := LeftPadCh(S, ' ', Len);
  294. End;
  295.  
  296. Procedure Null;
  297.   {-vyrobi prazdny retezec}
  298. Begin
  299.   {$IfDef Win32}
  300.   S:='';
  301.   {$Else}
  302.   FillChar(S,SizeOf(S),#0);
  303.   {$EndIf}
  304. End;
  305.  
  306. Function Hash;
  307.   {-secte ordinalni hodnoty vsech prvku retezce}
  308. Var I:LongInt;
  309. Begin
  310.   Result := 0;
  311.   If S <> '' Then
  312.     For I := 1 To Length(S) Do Result := Result + Ord(S[I]);
  313. End;
  314.  
  315. Function Space;
  316.   {- vyrobi retezec vyplneny mezerami}
  317. Begin
  318.   Space := CharStr(' ',B);
  319. End;
  320.  
  321. Function MakeStr;{alias charstr}
  322.   {-vyrobi novy retezec vyplneny znaky C}
  323. Begin
  324.   MakeStr := StrStr(S,B);
  325. End;
  326.  
  327. Function TrimLead;
  328.   {-vraci zleva orezany retezec}
  329. Begin
  330.   Result:=S;
  331.   While (Length(Result)>0) And (Result[1] <= ' ') Do Delete(Result,1,1);
  332. End;
  333.  
  334. Function TrimTrail;
  335.   {-vraci zprava orezany retezec}
  336. Begin
  337.   Result := S;
  338.   While (Length(Result) > 0) And (Result[Length(Result)] <= ' ') Do
  339.     Delete(Result,Length(Result),1);
  340. End;
  341.  
  342. Function Trim;
  343.   {-vraci z obou stran orezany retezec}
  344. Begin
  345.   Result := TrimLead(TrimTrail(S));
  346. End;
  347.  
  348. Function  ZeroClip(Const S:String):String;
  349.   {-odrizne zleva nuly v cisle}
  350. Var
  351.   I :Word;
  352. Begin
  353.   Result := TrimLead(S);
  354.   If Result = '' Then Exit; {29.11.1999 J.B.}
  355.   If Result[1]<>'0' Then Exit;
  356.   If Mult(Result)=Length(Result) Then Begin
  357.     ZeroClip := '0';
  358.     Exit;
  359.   End;
  360.   I := 1;
  361.   While (I <= Length(Result)) And (Result[I] = '0') Do Inc(I);
  362.   Dec(I);
  363.   If I > 0 Then Delete(Result, 1, I);
  364. End;
  365.  
  366. Function  CapitalizeWord(Const S:String):String;
  367.  {-kazde slovo v retezci bude mit zvetseno prvni pismeno}
  368. Var
  369.   I: Integer;
  370.   CapitalizeNextLetter: Boolean;
  371. Begin
  372.   Result := StrLoCase(S);
  373.   CapitalizeNextLetter := True;
  374.   For I := 1 To Length(Result) Do Begin
  375.     If CapitalizeNextLetter And
  376.      ((Result[I] in ['a'..'z']) Or (Pos(Result[I],LoCharCS)>0)) then
  377.       Result[I] := UpCase(Result[I]);
  378.     CapitalizeNextLetter := Result[I] = ' ';
  379.   End;
  380. End;
  381.  
  382. Function CenterCh;
  383.   {-vrati znaky ch vycentrovany retezec v sirce width}
  384. Begin
  385.   Result := S;
  386.   If Length(S) < Width Then Begin
  387.     Result := CharStr(CH,Width);
  388.     Move(S[1], Result[Succ((Width-Length(S)) ShR 1)], Length(S));
  389.   End;
  390. End;
  391.  
  392. Function Center;
  393.   {-vrati mezerami vycentrovany retezec v sirce width}
  394. Begin
  395.   Center := CenterCh(S, ' ', Width);
  396. End;
  397.  
  398. Function WordCount;
  399.   {-vrati pocet slov oddelenych WordDelims}
  400. Var
  401.   I:Integer;
  402. Begin
  403.   Result := 0;
  404.   I := 1;
  405.   While I <= Length(S) Do Begin
  406.     {preskoc oddelovace}
  407.     While (I <= Length(S)) And (S[I] In WordDelims) Do Inc(I);
  408.     {dokud neni konec retezce, skakej po slovech}
  409.     If I <= Length(S) Then Inc(Result);
  410.     {a zde je konec slova}
  411.     While (I <= Length(S)) And Not(S[I] In WordDelims) Do Inc(I);
  412.   End;
  413. End;
  414.  
  415. Function ExtractWord;
  416.   {-zkopiruje na vystup N-te slovo oddelene WordDelims}
  417. Var
  418.   I,J:Word;
  419.   Count:Integer;
  420.   SLen:Integer;
  421. Begin
  422.   Count := 0;
  423.   I := 1;
  424.   Result := '';
  425.   SLen := Length(S);
  426.   While I <= SLen Do Begin
  427.     {preskoc oddelovace}
  428.     While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
  429.     {neni-li na konci retezce, bude nalezen zacatek slova}
  430.     If I <= SLen Then Inc(Count);
  431.     J := I;
  432.     {a zde je konec slova}
  433.     While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
  434.     {je-li toto n-te slovo, vloz ho na vystup}
  435.     If Count = N Then Begin
  436.       Result := Copy(S,I,J-I);
  437.       Exit
  438.     End;
  439.     I := J;
  440.   End; {while}
  441. End;
  442.  
  443. Function FindWord;
  444.  {-nalezne slovo what v seznamu slov oddelenych WordDelims}
  445. Var I,J:Integer;
  446. Begin
  447.   Result:=False;
  448.   I:=WordCount(S,WordDelims);
  449.   If I>0 Then
  450.     For J:=1 To I Do
  451.       If what=ExtractWord(J,S,WordDelims) Then Begin
  452.         Result:=True;
  453.         Exit;
  454.       End;
  455. End;
  456.  
  457. Function  GetFirstWord(Const S:String;WordDelims:CharSet):String;
  458.  {-poda na vystup prvni slovo retezce}
  459. Begin
  460.   GetFirstWord := '';
  461.   If WordCount(S,WordDelims)>0 Then
  462.     GetFirstWord := ExtractWord(1,S,WordDelims)
  463. End;
  464.  
  465. Function  GetLastWord(Const S:String;WordDelims:CharSet):String;
  466.  {-poda na vystup posledni slovo retezce}
  467. Begin
  468.   GetLastWord := '';
  469.   If WordCount(S,WordDelims)>0 Then
  470.     GetLastWord := ExtractWord(WordCount(S,WordDelims),S,WordDelims)
  471. End;
  472.  
  473. Function ChangeWord(N:TStrLen;Const Wrd,S:String;WordDelims:CharSet):String;
  474.  {-vymeni slovo uvozene oddelovaci na pozici za jine slovo}
  475. Var X:Integer;
  476. Begin
  477.   Result:=S;
  478.   X:=GetPos(N,Result,WordDelims);
  479.   PopWord(N,Result,WordDelims);
  480.   Insert(Wrd,Result,X);
  481. End;
  482.  
  483. Procedure WordWrap;
  484.   {-Seskladani slov so pozadovane delky radku}
  485. Var
  486.   InStLen:Byte Absolute InSt;
  487.   OutStLen:Byte Absolute OutSt;
  488.   OvrLen:Byte Absolute Overlap;
  489.   EndPos, BegPos:Word;
  490. Begin
  491.   {hledani konce radku}
  492.   If InStLen > Margin Then Begin
  493.     {nalezeni konce slova na okraji je-li to potreba}
  494.     EndPos := Margin;
  495.     While (EndPos <= InStLen) And (InSt[EndPos] <> ' ') Do Inc(EndPos);
  496.     If EndPos > InStLen Then EndPos := InStLen;
  497.     {odstran okrajove mezery}
  498.     While (InSt[EndPos] = ' ') And (EndPos > 0) Do Dec(EndPos);
  499.     If EndPos > Margin Then Begin
  500.       {nepradchazeji-li slovu mezery}
  501.       While (EndPos > 0) And (InSt[EndPos] <> ' ') Do Dec(EndPos);
  502.       {je-li EndPos = 0 potom to muzes zabalit}
  503.       If EndPos = 0 Then EndPos := Margin
  504.       Else {zarizni prazdne znaky}
  505.         While (InSt[EndPos] = ' ') And (EndPos > 0) Do Dec(EndPos);
  506.     End;
  507.   End
  508.   Else
  509.     EndPos := InStLen;
  510.  
  511.   {kopiruj nezabalene casti radku}
  512.   OutStLen := EndPos;
  513.   Move(InSt[1], OutSt[1], OutStLen);
  514.  
  515.   {nalezni pocatek pristiho slova v radku}
  516.   BegPos := EndPos+1;
  517.   While (BegPos <= InStLen) And (InSt[BegPos] = ' ') Do Inc(BegPos);
  518.  
  519.   If BegPos > InStLen Then OvrLen := 0
  520.   Else Begin
  521.     {kopiruj od pocatku pristiho slova ke konci radku}
  522.     OvrLen := Succ(InStLen-BegPos);
  523.     Move(InSt[BegPos], Overlap[1], OvrLen);
  524.   End;
  525.  
  526.   {je-li zadano zarovnej z prava retezec}
  527.   If PadToMargin And (OutStLen < Margin) Then Begin
  528.     FillChar(OutSt[OutStLen+1], Margin-OutStLen, ' ');
  529.     OutStLen := Margin;
  530.   End;
  531. End;
  532.  
  533. Procedure GetStartAndEndWord(N:TStrLen;S:String;WordDelims:CharSet;Var St,En:TStrLen);
  534.  {-nalezne zacatek a konec slova v indexu}
  535. Var
  536.   I,J,Count:Integer;
  537.   SLen:Integer;
  538. Begin
  539.   Count := 0;
  540.   I := 1;
  541.   St:=0;En:=0;
  542.   SLen := Length(S);
  543.   While I <= SLen Do Begin
  544.     {preskoc oddelovace}
  545.     While (I <= SLen) And (S[I] In WordDelims) Do Inc(I);
  546.     {neni-li na konci retezce, bude nalezen zacatek slova}
  547.     If I <= SLen Then Inc(Count);
  548.     J := I;
  549.     {a zde je konec slova}
  550.     While (J <= SLen) And Not(S[J] In WordDelims) Do Inc(J);
  551.     {je-li toto n-te slovo, vloz ho na vystup}
  552.     If Count = N Then Begin
  553.       St:=I;
  554.       En:=J-1;
  555.       Exit
  556.     End;
  557.     I := J;
  558.   End; {while}
  559. End;
  560.  
  561. Function PopWord;
  562.   {-vyrizne b-te slovo z retezce}
  563. Var
  564.   St,En:TSTRLen;
  565. Begin
  566.   GetStartAndEndWord(B,S,WordDelims,St,En);
  567.  
  568.   If St > 0 Then Begin
  569.     Result:=Copy(S,St,En-St+1);
  570.     Delete(S,St,En-St+1);
  571.   End;
  572. {  SS := ExtractWord(B,S,WordDelims);
  573.   If SS <> '' Then Delete(S,Pos(SS,S),Length(SS));
  574.   PopWord := SS;}
  575. End;
  576.  
  577. Function GetPos;
  578.  {-vrati pocatecni pozici slova}
  579. Var
  580.   En:TSTRLen;
  581. Begin
  582.   {-vraci pocatecni pozici b-teho slova}
  583.   GetStartAndEndWord(B,S,WordDelims,Result,En);
  584. {  GetPos := 0;
  585.   SS := ExtractWord(B,S,WordDelims);
  586.   If SS <> '' Then GetPos := Pos(SS,S);}
  587. End;
  588.  
  589. Function GetEnd;
  590.   {-vraci koncovou pozici b-teho slova}
  591. Var
  592.   St:TSTRLen;
  593. Begin
  594.   GetStartAndEndWord(B,S,WordDelims,St,Result);
  595. {  GetEnd := 0;
  596.   SS := ExtractWord(B,S,WordDelims);
  597.   If SS <> '' Then GetEnd := Pos(SS,S)+Length(SS)-1;}
  598. End;
  599.  
  600. Function InsWord;
  601.   {-na pozici iWord vlozi jine slovo}
  602. Var
  603.   cc: TSTRLen;
  604. Begin
  605.   cc := Pos (iWord, cString);
  606.   If cc <> 0 Then Begin
  607.     Delete (cString, cc, Length(iWord));
  608.     Insert (cWord, cString, cc);
  609.   End;
  610.   InsWord := cString;
  611. End;
  612.  
  613. Function Push;
  614.   {-do retezce vlozi znaky jineho retezce od prislusne pozice}
  615. Begin
  616.   Result := Dest; {je vlozeno za retezcem}
  617.   If Posic > Length(Result) Then Result := Pad(Result,Posic)+Source
  618.   Else Begin
  619.     If (Posic+Length(Source))>Length(Result) Then
  620.       Result := Pad(Result,Posic+Length(Source));
  621.     Move(Source[1],Result[Posic],Length(Source));
  622.   End;
  623. End;
  624.  
  625. Function Smash;
  626.   {-vypusti znak C z retezce S}
  627. Var I :Integer;
  628. Begin
  629.   Result := '';
  630.   If S <> '' Then
  631.     For I := 1 To Length(S) Do
  632.       If S[I] <> C Then Result := Result + S[I];
  633. End;
  634.  
  635. Function Mask;
  636.   {-vstupem je znak masky CharOfMask, ktery je hledan v masce StrMask a to
  637.    od prvni pozice. Kdyz je nalezen, jsou vraceny funkci znaky z Matrice,
  638.    odpovidajici pozici vuci masce a NextPosic ukazuje na dalsi znak za
  639.    vracenym podretezcem; Podminka: Length(StrMask)=Length(Matrice)}
  640. Var
  641.   O: Integer;
  642. Begin
  643.   Mask := '';
  644.   If (StrMask = '') Or (Length(StrMask)<>Length(Matrice)) Then Exit;
  645.   If NextPosic = 0 Then NextPosic := 1; {jen kdyz je 0 pak od zacatku}
  646.   While (NextPosic <= Length (StrMask) ) And (StrMask [NextPosic] <> CharOfMask) Do
  647.     Inc (NextPosic);
  648.   O := NextPosic;
  649.   While (O <= Length (StrMask) ) And (StrMask [O] = CharOfMask) Do Inc (O);
  650.   Mask := Copy (Matrice, NextPosic, O - NextPosic);
  651. End;
  652.  
  653. Function Count;
  654.   {-nacita od posic len stejnych znaku ch}
  655. Var SS:String;
  656.   I :Integer;
  657. Begin
  658.   SS := Copy(Dest,Posic,255);{od urcite pozice}
  659.   Posic := 0;
  660.   Len := 0;
  661.   I := Pos(CH,SS);
  662.   If I <> 0 Then Begin
  663.     Posic := I;
  664.     While SS[I+Len] = CH Do Inc(Len);
  665.     If Length(SS) <> Length(Dest) Then
  666.       Posic := Length(Dest) - Length(SS) + Posic;
  667.   End;{neni nic}
  668.   Count := Posic <> 0;
  669. End;
  670.  
  671. Procedure Flop;
  672.   {-prohodi obsahy dvou retezcu}
  673. Var SS:String;
  674. Begin
  675.   SS := S1;
  676.   S1 := S2;
  677.   S2 := SS
  678. End;
  679.  
  680. Function Strip;
  681.    {-nastavuje dle masky novy retezec}
  682. Var I:Integer;
  683.   S,SS:String;
  684. Begin
  685.   Strip := Source;
  686.   If (Source = '') Or (Mask = '') Then Exit;
  687.   S := '';
  688.   SS := Pad(Source,Length(Mask));
  689.   For I := 1 To Length(Mask) Do
  690.     If Mask[I] = MaskZipChar Then S := S + SS[I]; {J.B. 12.12.95}
  691.   Strip := S;
  692. End;
  693.  
  694. Function Change;
  695.   {-zmeni znaky dest za source}
  696. Var I:Integer;
  697. Begin
  698.   Result := S;
  699.   If Result = '' Then Exit;
  700.   For I := 1 To Length(Result) Do If Result[I] = Source Then Result[I] := Dest;
  701. End;
  702.  
  703. Function  ChangeTo(S:String;Source:CharSet;Dest:Char):String;
  704.   {-zmeni n znaku dest za source}
  705. Var I:Integer;
  706. Begin
  707.   Result := S;
  708.   If Result = '' Then Exit;
  709.   For I := 1 To Length(Result) Do
  710.     If Result[I] in Source Then Result[I] := Dest;
  711. End;
  712.  
  713. Function Zip;
  714.   {-zaformatuje retezec podle masky}
  715. Var I,J:Integer;
  716.   S:String;
  717. Begin
  718.   If Mask = '' Then Begin Zip := Source;Exit End;
  719.   Zip := '';
  720.   S := '';
  721.   If Source = '' Then Begin Zip := Change(Mask,MaskZipChar,' ');Exit; End;
  722.   J := 1;
  723.   For I := 1 To Length(Mask) Do
  724.     If Mask[I] = MaskZipChar Then Begin
  725.       S := S +Source[J];
  726.       If J<Length(Source) Then Inc(J)
  727.       Else Break;
  728.     End
  729.   Else S := S + Mask[I];
  730.   Zip := S;
  731. End;
  732.  
  733. Function Turn;
  734.  {-otoci retezec}
  735. Var
  736.   I:Integer;
  737. Begin
  738.   Result := '';
  739.   If S <> '' Then
  740.     For I := 1 To Length(S) Do
  741.       Result := S[I] + Result;
  742. End;
  743.  
  744. Function Entab;
  745.   {-nahradi vsechny mezery v dane delce jednim tabelatorem}
  746. Var
  747.   First:Integer;
  748.   S:String;
  749. Begin
  750.   S := Sx;
  751.   While Pos(CharStr(' ',TabSize),S) <> 0 Do Begin
  752.     First := Pos(CharStr(' ',TabSize),S);
  753.     Delete(S,first,Tabsize);
  754.     Insert(#9,S,first);
  755.   End;
  756.   EnTab := S;
  757. End;
  758.  
  759. Function Detab;
  760.  {-odstrani vsechny znaky tabelatoru}
  761. Var
  762.   first:Integer;
  763.   S:String;
  764. Begin
  765.   S := Sx;
  766.   While Pos(#9,S) <> 0 Do Begin
  767.     first := Pos(#9,S);
  768.     Delete(S,first,1);
  769.     Insert(CharStr(' ',TabSize),S,first);
  770.   End;
  771.   DeTab := S;
  772. End;
  773.  
  774. Function HasExtension;
  775.   {-kdyz existuje, vrati pozici separatoru extenze jmena}
  776. Var
  777.   I:Integer;
  778. Begin
  779.   DotPos := 0;
  780.   For I := Length(Name) Downto 1 Do
  781.     If (Name[I] = '.') And (DotPos = 0) Then DotPos := I;
  782.   HasExtension := (DotPos > 0) And (Pos('\', Copy(Name, Succ(DotPos), 64)) = 0);
  783. End;
  784.  
  785. Function DefaultExtension;
  786.   {-kdyz extenze existuje, vrati nezmeneno jinak extenzi doplni}
  787. Var
  788.   DotPos:Word;
  789. Begin
  790.   If HasExtension(Name, DotPos) Then DefaultExtension := Name
  791.   Else DefaultExtension := Name+'.'+Ext;
  792. End;
  793.  
  794. Function ForceExtension;
  795.   {-nahradi extenzi jinou extenzi}
  796. Var
  797.   DotPos:Word;
  798. Begin
  799.   If HasExtension(Name, DotPos) Then ForceExtension := Copy(Name, 1, DotPos)+Ext
  800.   Else ForceExtension := Name+'.'+Ext;
  801. End;
  802.  
  803. Function JustExtension;
  804.   {-vraci pouze extenzi souboru}
  805. Var
  806.   DotPos:Word;
  807. Begin
  808.   If HasExtension(PathName, DotPos) Then JustExtension := Copy(PathName, Succ(DotPos), 3)
  809.   Else JustExtension := '';
  810. End;
  811.  
  812. Function JustFilename;
  813.   {-vraci pouze cele jmeno souboru tj .jmeno a extenzi}
  814. Var
  815.   SS:String;
  816.   I:Integer;
  817. Begin
  818.   SS := Turn(PathName);
  819.   I := Pos('\',SS);  {pr. c:\rwewe\kokol.txt}
  820.   If I = 0 Then I := Pos(':',SS);
  821.   {neobsahuje-li ani \ ani : pak to muze byt jmeno}
  822.   If I = 0 Then JustFilename := PathName
  823.   Else JustFilename := Turn(Copy(SS,1,I-1));
  824. End;
  825.  
  826. Function JustPathName;
  827.   {-vraci pouze cestu ze jmena souboru}
  828. Var
  829.   SS:String;
  830.   I:Integer;
  831. Begin
  832.   SS := Turn(PathName);
  833.   I := Pos('\',SS);  {pr. c:\rwewe\kokol.txt}
  834.   If I = 0 Then I := Pos(':',SS);
  835.   If I = 0 Then JustPathName := '' {not path}
  836.   Else JustPathName := Turn(Copy(SS,I+1,255));
  837. End;
  838.  
  839. Function AddLastChar;
  840.   {-prida \ ke jmenu direktorare}
  841. Begin
  842.   If (DirName='') Or (DirName[Length(DirName)]=C) Then Result := DirName
  843.   Else Result := DirName+C;
  844. End;
  845.  
  846. Function RemLastChar;
  847.   {-ubere \ ke jmenu direktorare}
  848. Begin
  849.   Result := DirName;
  850.   If Length(DirName)>1 Then {$IfNDef Win32}Dec(Byte(Result[0]))
  851.                             {$Else}Result:=Copy(Result,1,Length(Result)-1)
  852.                             {$EndIf};
  853. End;
  854.  
  855. Function CleanDOSFileName(FileName:String):String;
  856.   {-vraci jmeno souboru max 8 znaku a 3 znaky pro extenzi}
  857. Var
  858.   S,Dir,Name,Ext: String;
  859. Begin
  860.   S := Turn(FileName);
  861.   If Pos('.',S)=0 Then Ext:='.'
  862.   Else Begin
  863.     Ext:=Turn(Copy(S,1,Pos('.',S)));
  864.     Delete(S,1,Pos('.',S));
  865.   End;
  866.   If Pos('\',S)=0 Then
  867.     If Pos(':',S)>1 Then Begin
  868.       Name:=Turn(Copy(S,1,Pos(':',S)-1));
  869.       Delete(S,1,Pos(':',S)-1);
  870.       Dir:=Turn(S);
  871.     End
  872.     Else Begin
  873.       Name := Turn(S);
  874.       Dir :='';
  875.     End
  876.   Else Begin
  877.     Name := Turn(Copy(S,1,Pos('\',S)-1));
  878.     Delete(S,1,Pos('\',S)-1);
  879.     Dir := Turn(S);
  880.   End;
  881.   {FSplit(FileName,Dir,Name,Ext);}
  882.   Result := Concat(Copy(Name,1,8),Copy(Ext,1,4));
  883. End;
  884.  
  885. Function TestFileName;
  886.   {-testuje dosovske jmeno na nepovolene znaky}
  887.   {-vraci false obsahuje-li jmeno souboru nepovolene znaky}
  888. Const InExt  = ['''','/','\','[',']',':',';','+','=',',','*','?','|'];
  889.       InPath = ['''','/','[',']',';','+','=',',','*','?','|'];
  890.       InName = ['''','/','\','[',']',':',';','+','=',',','*','?','|'];
  891. Var
  892.   I:Integer;
  893.   Path:String[28];
  894.   Name:String[8];
  895.   Ext:String[3];
  896. Begin
  897.   Result := False;
  898.   Path := JustPathName(FName);
  899.   Name := JustName(FName);
  900.   Ext := JustExtension(FName);
  901.   If Name='' Then Exit;{jmeno nemuze byt prazdne}
  902.   For I := 1 To Length(Path) Do If (Path[I] in InPath) Then Exit;
  903.   For I := 1 To Length(Name) Do If (Name[I] in InName) Then Exit;
  904.   For I := 1 To Length(Ext) Do If (Ext[I] in InExt) Then Exit;
  905.   Result := True;
  906. End;
  907.  
  908. Function ShortDirName;
  909.   {-vraci retezec DOS jmena bez strednich slov}
  910.   Function FindBackSlash(Posic:Byte;S:String):Byte;
  911.   Var
  912.     I:Byte;
  913.   Begin
  914.     FindBackSlash := 0;
  915.     If Length(S) = 0 Then Exit;
  916.     Repeat I := Pos('\',S); Until I >= Posic;
  917.     FindBackSlash := I
  918.   End;
  919. Var
  920.   Q, S: String;
  921.   I, L, C: Integer;
  922. Begin
  923.   Q := AddLastChar('\', PName);{opraveno 30.11.2000 L.Taborsky}
  924.   ShortDirName := Q;
  925.   L := Length(Q);
  926.   If L <= Len Then Exit;
  927.   C := 1;
  928.   If Q[1] <> '\' Then  Begin
  929.     S := Copy(Q,1,3);
  930.     Delete(Q,1,3);
  931.   End
  932.   Else Begin
  933.     S := '\';
  934.     Delete(Q,1,1);
  935.   End;
  936.   Repeat
  937.     I := FindBackSlash(C,Q);
  938.     Delete(Q,1,I);
  939.   Until Length(S+'..\'+Q) <= Len;
  940.   ShortDirName := S+'..\'+Q
  941. End;
  942.  
  943. Function ShortFileName;
  944.  {-zkrati priliz dlouhe jmeno souboru}
  945. Begin
  946.   ShortFileName := AddLastChar('\',ShortDirName(Len -
  947.   Length(JustFileName(FName)) - 1,
  948.   JustPathName(FName))) + JustFileName(FName);
  949. End;
  950.  
  951. Function JustName;
  952.   {-vrat pouze jmeno bez extense a cesty}
  953. Var
  954.   SS:String;
  955. Begin
  956.   SS := JustFileName(PathName);
  957.   If Pos('.',SS) <> 0 Then JustName := Copy(SS,1,Pos('.',SS)-1)
  958.   Else JustName := SS
  959. End;
  960.  
  961. Function Mult;
  962.  {-}
  963. Var N:Integer;
  964. Begin
  965.   N := 0;
  966.   While (S[Succ(N)] = S[1]) And (N < Length(S)) Do Inc(N);
  967.   Mult := N;
  968. End;
  969.  
  970. Function Num;
  971.  {-prevede cislo ze soustavy 2..36 na desitkove}
  972. Var
  973.   I:Integer;
  974.   N:LongInt;
  975. Begin
  976.   N := 0;
  977.   If Soustava In [2..36] Then
  978.     For I := 1 To Length(S) Do
  979.       If UpCase(S[I]) In ['A'..'Z'] Then N := N*Soustava + Ord(UpCase(S[I]))-Ord('A')+10
  980.       Else If UpCase(S[I]) In ['0'..'9'] Then N := N*Soustava + Ord(S[I])-Ord('0');
  981.   NUM := N
  982. End;
  983.  
  984. Function Doc;
  985.  {-prevede desitkove cislo na cislo ze soustavy 2..36}
  986. Var S:String;
  987.   I:Integer;
  988. Begin
  989.   S := '';
  990.   If Soustava In [2..36] Then
  991.     Repeat
  992.       I := L Mod Soustava;
  993.       If I In [0..9] Then S := Chr(Ord('0')+I) + S
  994.       Else S := Chr(I - 10 + Ord('A')) + S;
  995.       L := L Div Soustava;
  996.     Until L = 0;
  997.   Doc := S
  998. End;
  999.  
  1000. Function PackNum;
  1001.  {-jednoduche zapakovani cisla}
  1002. Var
  1003.   I:Byte;
  1004.   SS:String;
  1005. Begin
  1006.   PackNum := ''; {vystupni retezec}
  1007.   If S = '' Then Exit; {kdyz je vstup prazdny pak ven}
  1008.   SS := '';  {nuluj pomocne retezce}
  1009.   For I := 1 To Length(S) Do Begin
  1010.     If Odd(I) {je liche} Then
  1011.       SS := SS + Chr(16 * (Ord(S[I])-Ord('0')) + $F)
  1012.     Else
  1013.       Byte(SS[Length(SS)]) := 16*(Ord(SS[Length(SS)]) ShR 4)+(Ord(S[I])-Ord('0'));
  1014.   End;
  1015.   PackNum := SS;
  1016. End;
  1017.  
  1018. Function UnpackNum;
  1019.  {-jednoduche rozpakovani cisla}
  1020. Var
  1021.   I,X:Byte;
  1022.   SS:String;
  1023. Begin
  1024.   UnpackNum := '';
  1025.   If S = '' Then Exit;
  1026.   SS := '';
  1027.   For I := 1 To Length(S) Do Begin
  1028.     X := Ord(S[I]);
  1029.     If (X ShR 4) <> $F Then SS := SS + Chr((X ShR 4)+Ord('0'));
  1030.     If (X And $F) <> $F Then SS := SS +Chr((X And $F)+Ord('0'));
  1031.   End;
  1032.   UnpackNum := SS
  1033. End;
  1034.  
  1035. Function Str3Long;
  1036.  {-nacteni cisla ze retezce do prvniho neciselneho znaku}
  1037. Var SS:String;
  1038.   I:Byte;
  1039.   L:LongInt;
  1040.   code:Integer;
  1041. Begin
  1042.   Str3Long := 0;
  1043.   SS:=Trim(S);
  1044.   If SS='' Then Exit; {fixed 19.12.2001}
  1045.   I:=1;
  1046.   If SS[I] In ['+','-'] Then Inc(I);
  1047.   While SS[I] In ['0'..'9'] Do Inc(I);
  1048.   Val(Copy(SS,1,I-1), L, code);
  1049.   If code = 0 Then Str3Long := L;
  1050. End;
  1051.  
  1052. Function Str2Long;
  1053.   {-prevede string na longint, true kdyz ok}
  1054. Var
  1055.   code:Integer;
  1056. Begin
  1057.   Val(Trim(S), I, code);
  1058.   Result := code = 0;
  1059. End;
  1060.  
  1061. Function Str2Word;
  1062.   {-prevede string na word, true kdyz ok}
  1063. Var
  1064.   code:Integer;
  1065. Begin
  1066.   Val(Trim(S), I, code);
  1067.   Result := code = 0
  1068. End;
  1069.  
  1070. Function Str2Int;
  1071.   {-prevede string na integer, true kdyz ok}
  1072. Var
  1073.   code:Integer;
  1074. Begin
  1075.   Val(Trim(S), I, code);
  1076.   Result := code = 0
  1077. End;
  1078.  
  1079. Function Str2Real;
  1080.   {-prevede string na real, true kdyz ok}
  1081. Var
  1082.   code:Integer;
  1083. Begin
  1084.   Val(Trim(S), R, code);
  1085.   Result := code = 0
  1086. End;
  1087.  
  1088. Function Long2Str;
  1089.   {-prevede long/word/integer/byte/shortint na retezec}
  1090. Var
  1091.   S:String;
  1092. Begin
  1093.   Str(L, S);
  1094.   Long2Str := S;
  1095. End;
  1096.  
  1097. Function Real2Str;
  1098.   {-prevede real na retezec}
  1099. Var
  1100.   S:String;
  1101. Begin
  1102.   Str(R:Width:Places, S);
  1103.   Real2Str := S;
  1104. End;
  1105.  
  1106. Function Form;
  1107.  {-nove formatovani realneho cisla dle masky}
  1108.  Function PW(Zaklad,Na:Integer):Extended;
  1109.  Var I:Integer;
  1110.  Begin
  1111.    Result:=0;
  1112.    If (Na=0) Or (Zaklad=0) Then Exit;
  1113.    Result:=Zaklad;
  1114.    For I:= 1 To Na-1 Do
  1115.      Result:=Result*Zaklad
  1116.  End;
  1117. Var
  1118.   Tecka:Integer;
  1119.   Vysledek,Pred,Za:String;
  1120.   Cela,Zlom:String;
  1121.   E:Extended;
  1122. Begin
  1123.   Form := '';
  1124.   If Mask = '' Then Begin
  1125.     Str(R:20:7,Vysledek);
  1126.     If Vysledek = '' Then Exit;
  1127.     Vysledek := Turn(Trim(Vysledek));
  1128.     If Vysledek[1] = '0' Then
  1129.       Vysledek := Copy(Vysledek,Mult(Vysledek),255);
  1130.     Vysledek := Turn(Trim(Vysledek));
  1131.     Form := Vysledek;
  1132.     Exit;
  1133.   End;
  1134.   Tecka := Pos('.',Mask);
  1135.   Za:='';
  1136.   {maska, jen vyznamne cislice}
  1137.   If Tecka<>0 Then
  1138.   Begin
  1139.     Pred := Copy(Mask,1,Tecka-1);
  1140.     Pred:=StripChars(Pred,[MaskZipChar]);
  1141.     Za := Copy(Mask,Tecka+1,255);
  1142.     Za := StripChars(Za,[MaskZipChar]);
  1143.   End
  1144.   Else
  1145.     Pred:=StripChars(Mask,[MaskZipChar]);
  1146.   Str(R:20:8,Vysledek);
  1147.   Cela := Trim(Copy(Vysledek,1,Pos('.',Vysledek)-1));
  1148.   Zlom := Trim(Copy(Vysledek,Pos('.',Vysledek)+1,255));
  1149.   If Zlom[Length(Zlom)] = '0' Then Begin{odstrani koncove nuly}
  1150.     Zlom := Copy(Zlom,1,Length(Zlom)-Mult(Turn(Zlom)));
  1151.     If Zlom='' Then Zlom:='0'; {15.7.1998}
  1152.   End;
  1153.   {------------------------------------------------------------ CELE CISLO ----}
  1154.   If Tecka = 0 Then Begin {celociselne}
  1155.     Vysledek := Cela;
  1156.     E:=Frac(R);
  1157.     If E>=0.5 Then E:=R+1 Else E:=R;
  1158.     Str(Trunc(E):20,Vysledek);
  1159.     Vysledek:=Trim(Vysledek);
  1160.  
  1161.     If Length(Pred)<Length(Vysledek) Then Vysledek := Change(Mask,MaskZipChar,'*')
  1162.     Else Vysledek := LeftPad(Vysledek,Length(Pred));
  1163.     {zaformatuje napr. XXX XXX => 999 999}
  1164.     Vysledek:=Turn(Zip(Turn(Mask),Turn(Vysledek)));
  1165.     Result := Vysledek;
  1166.     Exit;
  1167.   End;
  1168.   {---------------------------------------------------------- REALNE CISLO ----}
  1169.   If Length(Cela)>Length(Pred) Then Vysledek := Change(Mask,MaskZipChar,'*') {preteceni cele casti}
  1170.   Else Begin
  1171.     Vysledek:=Zlom;
  1172.     If Za<>'' Then Begin {je-li nejaky}
  1173.       If Length(Za)<Length(Vysledek) Then
  1174.       Begin
  1175.         E:=Frac(R);
  1176.         {vynasob}
  1177.         E:=E*PW(10,Length(Za));
  1178.         {zaokrouhli}
  1179.         If Frac(E)>=0.5 Then E:=E+1;
  1180.         Str(Trunc(E):20,Vysledek);
  1181.         Vysledek := LeftPadCh(TrimLead(Vysledek),'0',20);
  1182.       End
  1183.     End;
  1184.     Zlom:=Trim(Vysledek);
  1185.     If Zlom[Length(Zlom)] = '0' Then Begin{odstrani koncove nuly}
  1186.       Zlom := Copy(Zlom,1,Length(Zlom)-Mult(Turn(Zlom)));
  1187.       If Zlom='' Then Zlom :='0'{15.7.1998}
  1188.     End;
  1189.     Vysledek:=Turn(Zip(Turn(Copy(Mask,1,Tecka-1)),Turn(Cela)))+'.';
  1190.     Cela := Copy(Mask,Tecka+1,255);
  1191.     Vysledek:= Vysledek+ Zip(Cela,Copy(Zlom,Length(Zlom)-Length(Cela)+1,20));
  1192.   End;
  1193.   Result := Vysledek;
  1194. End;
  1195.  
  1196. Function Trans;
  1197.  {-prevody CZ do ruznych soustav}
  1198. Type
  1199.   PTab=^TTab;
  1200.   TTab= Array [0..8] Of String [128];
  1201. Var
  1202.   VTab:PTab;
  1203.   Procedure XchgCh (Var C: Char; _z, _do: Byte);
  1204.   Var
  1205.     I, X:Byte;
  1206.   Begin
  1207.     If C < #128 Then Exit;
  1208.     {CH :=TTab[_z,Ord(C)];}
  1209.     For I := 1 To 128 Do Begin {posice ve vstupnim souboru}
  1210.       X := Pos (C, VTab^ [_z] );
  1211.       If X <> 0 Then Begin
  1212.         C := VTab^ [_do, X];
  1213.         Exit;
  1214.       End;
  1215.     End;
  1216.   End;
  1217. Var
  1218.   S: String;
  1219.   I: Integer;
  1220. Begin
  1221.   Trans := '';
  1222.   S := St;
  1223.   If Length (S) = 0 Then Exit;
  1224.   New(VTab);
  1225.   Try
  1226.     VTab^[0]:={Kam} 'ÇüéâäàåçêëèïîìÄÅÉæÆôöòûùÿÖÜ¢£¥₧ƒáíóúñѪº¿⌐¬½¼¡«»░▒▓' +
  1227.   '│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■';
  1228.     VTab^[1]:={Win} '╚ⁿΘ∩Σ╧ìΦ∞╠┼═╛σ─┴╔₧Ä⌠÷╙∙┌²╓▄è╝▌╪¥ßφ≤·≥╥┘╘Ü°α└/º½╗---'
  1229.   + '||+++++|++++++--+ù+||++--|-+----++++++++--||-'
  1230.   + '|▀|╢||╡||||||||||▒||||:≈░ò╖||||';
  1231.     VTab^[2]:={W31} '╚ⁿΘ∩Σ╧ìΦ∞╠┼═╛σ─┴╔₧Ä⌠÷╙∙┌²╓▄è╝▌╪¥ßφ≤·≥╥┘╘Ü°α└ !½╗   '
  1232.   + '|++++++|+++++++++-++++++++-+++++++++++++     a▀gpEouyoOO≡ooE ='
  1233.   + '▒><[]≈~░╖òVn2 ';
  1234.     VTab^[3]:={Ecm} '╚ⁿΘ∩Σ╧½Φ∞╠┼═╡σ─┴╔╛«⌠÷╙∙┌²╓▄⌐Ñ▌╪╗ßφ≤·≥╥┘╘╣°α└/º<>---'
  1235.   + '||+++++|++++++--+ù+||++--|-+----++++++++--||-'
  1236.   + '|▀|╢||||||||||||||||||:≈░ |||||';
  1237.     VTab^[4]:={La2} '¼üé╘ä╥¢ƒ╪╖æ╓ûÆÄ╡ɺªôöαàΘ∞Öܵòφⁿ£áíóúσ╒▐Γτ²ΩΦ4!«»░▒▓'
  1238.   + '│┤┤┤┐┐╣║╗╝╝╝┐└┴┬├─┼├├╚╔╩╦╠═╬┴┴┬┬└└┌┌┼┼┘┌█▐||▀aßGPEoutFOQdqfe+=-'
  1239.   + '><II÷≈°∙·|h2■';
  1240.     VTab^[5]:={Usa} 'CüédäDTceELIllÄAÉzZôöOuUyÖÜSLYRtáíóúnNUOsrrR½ «»░▒▓'
  1241.   +'│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■';
  1242.     VTab^[6]:={Ibm} 'CuedaDTceELIllAAEzZooOuUyOUSLYRtaiounNUOsrrR¼¡«»░▒▓'
  1243.   +'│┤╡╢╖╕╣║╗╝╜╛┐└┴┬├─┼╞╟╚╔╩╦╠═╬╧╨╤╥╙╘╒╓╫╪┘┌█▄▌▐▀αßΓπΣσµτΦΘΩδ∞φε∩≡±≥≤⌠⌡÷≈°∙·√ⁿ²■';
  1244.     VTab^[7]:={Sem} 'CuedaDTceELIllAAEzZooOuUyOUSLYRtaiounNUOsrrR¼¡«»   '
  1245.   + '|++++++|+++++++++-++++++++-++++++++++++++-||+abgpeoutfoqdqfe+=-><():=~..'
  1246.   + 'Vn2 ';
  1247.     VTab^[8]:={Mac} 'ëƒÄô æΦï₧¥╜Ω║╛ τâ∞δÖÜε≤≥∙àåß╗°█ΘçÆù£╦┼±∩Σ▐┌┘ ñ╟╚   '
  1248.   + '            ┬    ╤á                           º  ╖    ╫ ╢      │▓  ╓ '
  1249.   + 'í╙╥├   ';
  1250.     For I := 1 To Length (St) Do XchgCh (S [I], odkud, kampak);
  1251.   Finally
  1252.     Dispose(VTab);
  1253.   End;
  1254.   Trans := S;
  1255. End;
  1256.  
  1257. Function Roman2Int(Const S: String): LongInt;
  1258.  {-rimska cislice do int}
  1259. Const
  1260.   RomanChars = ['C','D','I','L','M','V','X'];
  1261.  
  1262.   RomanValues: array['C'..'X'] of Word =
  1263.     (100,500,0,0,0,0,1,0,0,50,1000,0,0,0,0,0,0,0,0,5,0,10);
  1264. var
  1265.   Index, Next: Char;
  1266.   I: Integer;
  1267.   Negative: Boolean;
  1268. begin
  1269.   Result := 0;
  1270.   I := 0;
  1271.   Negative := (Length(S) > 0) and (S[1] = '-');
  1272.   if Negative then Inc(I);
  1273.   while (I < Length(S)) do begin
  1274.     Inc(I);
  1275.     Index := UpCase(S[I]);
  1276.     if Index in RomanChars then begin
  1277.       if Succ(I) <= Length(S) then Next := UpCase(S[I + 1])
  1278.       else Next := #0;
  1279.       if (Next in RomanChars) and (RomanValues[Index] < RomanValues[Next]) then
  1280.       begin
  1281.         Inc(Result, RomanValues[Next]);
  1282.         Dec(Result, RomanValues[Index]);
  1283.         Inc(I);
  1284.       end
  1285.       else Inc(Result, RomanValues[Index]);
  1286.     end
  1287.     else begin
  1288.       Result := 0;
  1289.       Exit;
  1290.     end;
  1291.   end;
  1292.   if Negative then Result := -Result;
  1293. end;
  1294.  
  1295. function Int2Roman(Value: Longint): string;
  1296.  {-int na rimskou cislici}
  1297. Label
  1298.   A500, A400, A100, A90, A50, A40, A10, A9, A5, A4, A1;
  1299. begin
  1300.   Result := '';
  1301. {$IFNDEF WIN32}
  1302.   if (Value > MaxInt * 2) then Exit;
  1303. {$ENDIF}
  1304.   while Value >= 1000 do begin
  1305.     Dec(Value, 1000); Result := Result + 'M';
  1306.   end;
  1307.   if Value < 900 then goto A500
  1308.   else begin
  1309.     Dec(Value, 900); Result := Result + 'CM';
  1310.   end;
  1311.   goto A90;
  1312. A400:
  1313.   if Value < 400 then goto A100
  1314.   else begin
  1315.     Dec(Value, 400); Result := Result + 'CD';
  1316.   end;
  1317.   goto A90;
  1318. A500:
  1319.   if Value < 500 then goto A400
  1320.   else begin
  1321.     Dec(Value, 500); Result := Result + 'D';
  1322.   end;
  1323. A100:
  1324.   while Value >= 100 do begin
  1325.     Dec(Value, 100); Result := Result + 'C';
  1326.   end;
  1327. A90:
  1328.   if Value < 90 then goto A50
  1329.   else begin
  1330.     Dec(Value, 90); Result := Result + 'XC';
  1331.   end;
  1332.   goto A9;
  1333. A40:
  1334.   if Value < 40 then goto A10
  1335.   else begin
  1336.     Dec(Value, 40); Result := Result + 'XL';
  1337.   end;
  1338.   goto A9;
  1339. A50:
  1340.   if Value < 50 then goto A40
  1341.   else begin
  1342.     Dec(Value, 50); Result := Result + 'L';
  1343.   end;
  1344. A10:
  1345.   while Value >= 10 do begin
  1346.     Dec(Value, 10); Result := Result + 'X';
  1347.   end;
  1348. A9:
  1349.   if Value < 9 then goto A5
  1350.   else begin
  1351.     Result := Result + 'IX';
  1352.   end;
  1353.   Exit;
  1354. A4:
  1355.   if Value < 4 then goto A1
  1356.   else begin
  1357.     Result := Result + 'IV';
  1358.   end;
  1359.   Exit;
  1360. A5:
  1361.   if Value < 5 then goto A4
  1362.   else begin
  1363.     Dec(Value, 5); Result := Result + 'V';
  1364.   end;
  1365.   goto A1;
  1366. A1:
  1367.   while Value >= 1 do begin
  1368.     Dec(Value); Result := Result + 'I';
  1369.   end;
  1370. end;
  1371.  
  1372. Function  ExtractNumber(Const S:String):String;
  1373.   {-vytahni z retezce pouze cisla}
  1374. Var I:Integer;
  1375. Begin
  1376.   Result:='';
  1377.   If Trim(S)='' Then Exit;
  1378.   For I:=1 To Length(S) Do
  1379.     If S[I] in ['0'..'9'] Then Result := Result + S[I];
  1380. End;
  1381.  
  1382. Function  ExtractAlphaNum(Const S:String):String;
  1383.   {-vytahni z retezce pouze cisla a znaky}
  1384. Var I:Integer;
  1385. Begin
  1386.   Result:='';
  1387.   If Trim(S)='' Then Exit;
  1388.   For I:=1 To Length(S) Do
  1389.     If S[I] in ['0'..'9','a'..'z','A'..'Z'] Then Result := Result + S[I];
  1390. End;
  1391.  
  1392. Function  ExtractChars(Const S:String;chars:CharSet):String;
  1393. Var I:Integer;
  1394. Begin
  1395.   Result:='';
  1396.   If Trim(S)='' Then Exit;
  1397.   For I:=1 To Length(S) Do
  1398.     If S[I] in chars Then Result := Result + S[I];
  1399. End;
  1400.  
  1401. Function  ExtractAlphas(Const S:String):String;
  1402.   {-vytahni z retezce pouze znaky}
  1403. Var I:Integer;
  1404. Begin
  1405.   Result:='';
  1406.   If Trim(S)='' Then Exit;
  1407.   For I:=1 To Length(S) Do
  1408.     If S[I] in ['a'..'z','A'..'Z'] Then Result := Result + S[I];
  1409. End;
  1410.  
  1411. Function StripChars(S:String;ch:CharSet):String;
  1412.  {-vytahne jen pozadovane znkay z retezce}
  1413. Var I:Integer;
  1414. Begin
  1415.   Result:='';
  1416.   For I:=1 To Length(S) Do Begin
  1417.     If S[I] in ch Then Result := Result+S[I]
  1418.   End;
  1419. End;
  1420.  
  1421. Function htmlSrcEmail(Const S:String):String;
  1422.  {- search e-mail form source on string}
  1423.  {* hledej e-mail adresu v retezci}
  1424. Const PSEM=['A'..'Z','a'..'z','0'..'9','_','-','.','@'];
  1425. Var
  1426.   I,N:Integer;
  1427.   E:String;
  1428. Begin
  1429.   Result:='';
  1430.   I:=Pos('@',S);
  1431.   If I>1 Then N:=I-1 Else N:=1;
  1432.   While (S[N] in PSEM) And (N>1) Do Dec(N);
  1433.   If Not (S[N] in PSEM) Then Inc(N);
  1434.   E:=Copy(S,N,255);
  1435.   I:=Pos('@',E);
  1436.   While (E[I] in PSEM) And (I<Length(E)) Do Inc(I);
  1437.   If Not (E[I] in PSEM) Then Dec(I);
  1438.   E:=Copy(E,1,I);
  1439.   If (Length(Copy(E,1,Pos('@',E)-1))>0)
  1440.    And (Length(Copy(E,Pos('@',E)+1,255))>0) Then
  1441.     Result:=E;
  1442. End;
  1443.  
  1444. Function SetBit(Num,B:Byte):Byte;
  1445. Begin
  1446.   SetBit:=B or (1 shl Num);
  1447. End;
  1448.  
  1449. Function IsSetBit(Num,B:Byte):Boolean;
  1450. Begin
  1451.   IsSetBit:=(B And(1 shl Num))<>0;
  1452. End;
  1453.  
  1454. Function ReSetBit(Num,B:Byte):Byte;
  1455. Begin
  1456.   ReSetBit:=B And((1 shl Num) xor $FF);
  1457. End;
  1458.  
  1459. Function SetToggle(Num,B:Byte):Byte;
  1460. Begin
  1461.   SetToggle:=B xor (1 shl Num);
  1462. End;
  1463.  
  1464. Function ChangeXChars(FindChar,DestChar:Char;Const Source:String):String;
  1465.  {-for change table with spaces to one delimitiers}
  1466.  {-pro prevod tabulky s mezerami na jeden oddelovac}
  1467. Var
  1468.   I,N:Integer;
  1469.   Q:String;
  1470. Begin
  1471.   Result:='';
  1472.   If Source='' Then Exit;
  1473.   I:=1;
  1474.   While I<=Length(Source) Do
  1475.   Begin
  1476.     If Source[I]=FindChar Then
  1477.     Begin
  1478.       Q:=Copy(Source,I,Length(Source));
  1479.       N := Mult(Q);
  1480.       If N>1 Then
  1481.       Begin
  1482.         Inc(I,N-1);
  1483.         Result := Result + DestChar;
  1484.       End;
  1485.     End
  1486.     Else
  1487.       Result:=Result+Source[I];
  1488.     Inc(I);
  1489.   End;
  1490. End;
  1491.  
  1492. Function YesOrNo(B:Boolean):String;
  1493.   {-for convert boolean value to string -> ccYes and ccNo may be redefined}
  1494. Begin
  1495.   If B Then Result := ccYes
  1496.   Else Result := ccNo;
  1497. End;
  1498.  
  1499. Function YesOrNoEx(B:Boolean;Const StrYes,StrNo:String):String;
  1500.  {-pro booleanovskou hodnotu mozne pojmenovani}
  1501. Begin
  1502.   If B Then Result := StrYes
  1503.   Else Result := StrNo;
  1504. End;
  1505.  
  1506. Function TestTo(S:String;SArr: Array of String):Boolean;
  1507.  {-provede test zda nejaky ze sady argumentu je stejny jako vstupni retezec}
  1508. Var I:Integer;
  1509. Begin
  1510.   Result := True;
  1511.   For I := Low(SArr) To High(SArr) Do
  1512.     If S = SArr[I] Then Exit;
  1513.   Result := False;
  1514. End;
  1515.  
  1516. Function TestBeginTo(S:String;SArr: Array of String):Boolean;
  1517.  {-provede test zda nejaky ze sady argumentu je stejny jako prvnich n-znaky vstupniho retezce}
  1518. Var I:Integer;
  1519. Begin
  1520.   Result := True;
  1521.   For I := Low(SArr) To High(SArr) Do
  1522.     If Pos(SArr[I],S)=1 Then Exit;
  1523.   Result := False;
  1524. End;
  1525.  
  1526. function PosN(Substring,Mainstring:string;occurrence:integer):integer;
  1527. {
  1528. Function PosN get recursive - the "occurrence" the position of "Substring" in
  1529. "Mainstring". Does the Mainstring not contain Substring the result
  1530. is 0. Works with chars and strings.
  1531.  
  1532. Examples :
  1533. i:=PosN('s','swissdelphicenter.ch',2);
  1534. result -> i=4
  1535. i:=posn('x','swissdelphicenter.ch',1);
  1536. result -> i=0
  1537. i:=posn('delphi','swissdelphicenter.ch',1);
  1538. result -> i=6
  1539. }
  1540. Begin
  1541.   If Pos(substring,mainstring)=0 Then
  1542.   Begin 
  1543.     Result:=0; 
  1544.     Exit; 
  1545.   End 
  1546.   Else 
  1547.   Begin 
  1548.     If occurrence=1 Then 
  1549.       Result:=Pos(substring,mainstring)
  1550.     Else 
  1551.     Begin
  1552.       Result:=Pos(substring,mainstring)
  1553.        +PosN(substring,Copy(mainstring,(Pos(substring,mainstring)+1),Length(mainstring)),occurrence-1);
  1554.     End;
  1555.   End;
  1556. End;
  1557.  
  1558. End.