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