home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / PROG / PASCAL / TOTSRC.ZIP / TOTSTR.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1991-02-10  |  20.7 KB  |  866 lines
  1. {               Copyright 1991 TechnoJock Software, Inc.               }
  2. {                          All Rights Reserved                         }
  3. {                         Restricted by License                        }
  4.  
  5. {                             Build # 1.00                             }
  6.  
  7. Unit totSTR;
  8. {$I TOTFLAGS.INC}
  9.  
  10. {
  11.  Development Notes:
  12.  
  13.  
  14. }
  15.  
  16. INTERFACE
  17.  
  18. Uses totREAL, totINPUT;
  19.  
  20. CONST
  21.    MaxFixlength = 5;
  22.  
  23. TYPE
  24.    tJust = (JustLeft,JustCenter,JustRight);
  25.    tCase = (Lower,Upper,Proper,Leave);
  26.    tSign = (plusminus, minus, brackets, dbcr);
  27.  
  28.    pFmtNumberOBJ = ^FmtNumberOBJ;
  29.    FmtNumberOBJ = object
  30.       vPrefix: string[Maxfixlength];
  31.       vSuffix: string[Maxfixlength];
  32.       vSign: tSign;
  33.       vPad: char;
  34.       vThousandsSep: char;
  35.       vDecimalSep: char;
  36.       vJustification: tJust;
  37.       {...methods}
  38.       constructor Init;
  39.       procedure   SetPrefixSuffix(P,S:string);
  40.       procedure   SetSign(S:tSign);
  41.       procedure   SetSeparators(P,T,D:char);
  42.       procedure   SetJustification(J:tJust);
  43.       function    GetDecimal:char;
  44.       function    FormattedStr(StrVal:string; Width:byte):string;
  45.       function    FormattedLong(Val:longint; Width:byte):string;
  46.       function    FormattedReal(Val:extended; DP:byte; Width:byte):string;
  47.       destructor  Done;
  48.    end; {FmtNumberOBJ}
  49.  
  50. CONST
  51.    Floating = 255;
  52.    Fmtchars: set of char = ['!','#','@','*'];
  53.  
  54. function PicFormat(Input,Picture:string;Pad:char): string;
  55. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  56. function Squeeze(L:char;Str:string;Width:byte): string;
  57. function First_Capital_Pos(Str:string): byte;
  58. function First_Capital(Str:string): char;
  59. function Pad(PadJust:tJust;Str:string;Size:byte;ChPad:char):string;
  60. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  61. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  62. function PadRight(Str:string;Size:byte;ChPad:char):string;
  63. function Last(N:byte;Str:string):string;
  64. function First(N:byte;Str:string):string;
  65. function AdjCase(NewCase:tCase;Str:string):string;
  66. function SetUpper(Str:string):string;
  67. function SetLower(Str:string):string;
  68. function SetProper(Str:string):string;
  69. function OverType(N:byte;StrS,StrT:string):string;
  70. function Strip(L,C:char;Str:string):string;
  71. function LastPos(C:char;Str:string):byte;
  72. function PosAfter(C:char;Str:string;Start:byte):byte;
  73. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  74. function PosWord(Wordno:byte;Str:string):byte;
  75. function WordCnt(Str:string):byte;
  76. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  77. function ValidInt(Str:string):boolean;
  78. function ValidHEXInt(Str:string):boolean;
  79. function ValidReal(Str:string):boolean;
  80. function StrToInt(Str:string):integer;
  81. function StrToLong(Str:string):Longint;
  82. function HEXStrToLong(Str:string):longint;
  83. function StrToReal(Str:string):extended;
  84. function RealToStr(Number:extended;Decimals:byte):string;
  85. function IntToStr(Number:longint):string;
  86. function IntToHEXStr(Number:longint):string;
  87. function RealToSciStr(Number:extended; D:byte):string;
  88. function NthNumber(InStr:string;Nth:byte) : char;
  89.  
  90. IMPLEMENTATION
  91.  
  92. function PicFormat(Input,Picture:string;Pad:char): string;
  93. {}
  94. var
  95.    TempStr : string;
  96.    I,J : byte;
  97. begin
  98.    J := 0;
  99.    For I := 1 to length(Picture) do
  100.    begin
  101.        If not (Picture[I] in Fmtchars) then
  102.        begin
  103.            TempStr[I] := Picture[I] ;  {force any none format charcters into string}
  104.            inc(J);
  105.        end
  106.        else    {format character}
  107.        begin
  108.            If I - J <= length(Input) then
  109.               TempStr[I] := Input[I - J]
  110.            else
  111.               TempStr[I] := Pad;
  112.        end;
  113.    end;
  114.    TempStr[0] := char(length(Picture));  {set initial byte to string length}
  115.    PicFormat := Tempstr;
  116. end; {PicFormat}
  117.  
  118. function TruncFormat(Input:string;Start,Len:byte; Pad:char):string;
  119. {}
  120. var
  121.    L : byte;
  122. begin
  123.    if Start > 1 then
  124.       Delete(Input,1,pred(Start));
  125.    L := length(Input);
  126.    if L = Len then
  127.       TruncFormat := Input
  128.    else if L > Len then
  129.       TruncFormat := copy(Input,1,Len)
  130.    else
  131.       TruncFormat := Padleft(Input,Len,Pad);
  132. end; {TruncFormat}
  133.  
  134. function Squeeze(L:char; Str:string;Width:byte): string;
  135. {}
  136. const more:string[1] = #26;
  137. var temp : string;
  138. begin
  139.    if Width = 0 then
  140.    begin
  141.       Squeeze := '';
  142.       exit;
  143.    end;
  144.    Fillchar(Temp[1],Width,' ');
  145.    Temp[0] := chr(Width);
  146.    if Length(Str) < Width then
  147.       move(Str[1],Temp[1],length(Str))
  148.    else
  149.    begin
  150.       if upcase(L) = 'L' then
  151.       begin
  152.          move(Str[1],Temp[1],pred(width));
  153.          move(More[1],Temp[Width],1);
  154.       end
  155.       else
  156.       begin
  157.          move(More[1],Temp[1],1);
  158.          move(Str[length(Str)-width+2],Temp[2],pred(width));
  159.       end;
  160.    end;
  161.    Squeeze := Temp;
  162. end; {Squeeze}
  163.  
  164. function First_Capital_Pos(Str : string): byte;
  165. {}
  166. var StrPos : byte;
  167. begin
  168.    StrPos := 1;
  169.    while (StrPos <= length(Str))  and (AlphabetTOT^.IsUpper(ord(Str[StrPos])) = false) do
  170.       StrPos := Succ(StrPos);
  171.    if StrPos > length(Str) then
  172.       First_Capital_Pos  := 0
  173.    else
  174.       First_Capital_Pos := StrPos;
  175. end; {First_Capital_Pos}
  176.  
  177. function First_capital(Str : string): char;
  178. {}
  179. var B : byte;
  180. begin
  181.    B := First_Capital_Pos(Str);
  182.    if B > 0 then
  183.       First_Capital := Str[B]
  184.    else
  185.       First_Capital := #0;
  186. end; {First_capital}
  187.  
  188. function Pad(PadJust:tJust;Str:string;Size:byte;ChPad:char):string;
  189. {}
  190. begin
  191.    case PadJust of
  192.       JustLeft:  Pad := PadLeft(Str,Size,ChPad);
  193.       JustCenter:Pad := PadCenter(Str,Size,ChPad);
  194.       JustRight: Pad := PadRight(Str,Size,ChPad);
  195.    end; {case}
  196. end; {Pad}
  197.  
  198. function PadLeft(Str:string;Size:byte;ChPad:char):string;
  199. var temp : string;
  200. begin
  201.    fillchar(Temp[1],Size,ChPad);
  202.    Temp[0] := chr(Size);
  203.    if Length(Str) <= Size then
  204.       move(Str[1],Temp[1],length(Str))
  205.    else
  206.       move(Str[1],Temp[1],size);
  207.    PadLeft := Temp;
  208. end;
  209.  
  210. function PadCenter(Str:string;Size:byte;ChPad:char):string;
  211. var temp : string;
  212. L : byte;
  213. begin
  214.    fillchar(Temp[1],Size,ChPad);
  215.    Temp[0] := chr(Size);
  216.    L := length(Str);
  217.    if L <= Size then
  218.       move(Str[1],Temp[((Size - L) div 2) + 1],L)
  219.    else
  220.       Temp := copy(Str,1,L);
  221.    PadCenter := temp;
  222. end; {center}
  223.  
  224. function PadRight(Str:string;Size:byte;ChPad:char):string;
  225. var
  226.   temp : string;
  227.   L : integer;
  228. begin
  229.    fillchar(Temp[1],Size,ChPad);
  230.    Temp[0] := chr(Size);
  231.    L := length(Str);
  232.    if L <= Size then
  233.       move(Str[1],Temp[succ(Size - L)],L)
  234.    else
  235.       move(Str[1],Temp[1],size);
  236.    PadRight := Temp;
  237. end;
  238.  
  239. function Last(N:byte;Str:string):string;
  240. var Temp : string;
  241. begin
  242.    if N > length(Str) then
  243.       Temp := Str
  244.    else
  245.       Temp := copy(Str,succ(length(Str) - N),N);
  246.    Last := Temp;
  247. end;  {Last}
  248.  
  249. function First(N:byte;Str:string):string;
  250. var Temp : string;
  251. begin
  252.    if N > length(Str) then
  253.       Temp := Str
  254.    else
  255.       Temp := copy(Str,1,N);
  256.    First := Temp;
  257. end;  {First}
  258.  
  259. function AdjCase(NewCase:tCase;Str:string):string;
  260. {}
  261. begin
  262.    case Newcase of
  263.    Upper: Str := SetUpper(Str);
  264.    Lower: Str := SetLower(Str);
  265.    Proper: Str := SetProper(Str);
  266.    Leave:{do nothing};
  267.    end;
  268.    AdjCase := Str;
  269. end; {AdjCase}
  270.  
  271. function SetUpper(Str:string):string;
  272. var
  273.   I : integer;
  274. begin
  275.    for I := 1 to length(Str) do
  276.       Str[I] := AlphabetTOT^.GetUpcase(Str[I]);
  277.    SetUpper := Str;
  278. end;  {Upper}
  279.  
  280. function SetLower(Str:string):string;
  281. var
  282.   I : integer;
  283. begin
  284.    for I := 1 to length(Str) do
  285.       Str[I] := AlphabetTOT^.GetLocase(Str[I]);
  286.    SetLower := Str;
  287. end;  {Lower}
  288.  
  289. function SetProper(Str:string):string;
  290. var
  291.   I : integer;
  292.   SpaceBefore: boolean;
  293. begin
  294.    SpaceBefore := true;
  295.    Str := SetLower(Str);
  296.    For I := 1 to length(Str) do
  297.       if SpaceBefore and AlphabetTOT^.IsLower(ord(Str[I])) then
  298.       begin
  299.          SpaceBefore := False;
  300.          Str[I] := AlphabetTOT^.GetUpcase(Str[I]);
  301.       end
  302.       else
  303.          if (SpaceBefore = False) and (Str[I] = ' ') then
  304.             SpaceBefore := true;
  305.    SetProper := Str;
  306. end;
  307.  
  308. function OverType(N:byte;StrS,StrT:string):string;
  309. {Overlays StrS onto StrT at Pos N}
  310. var
  311.   L : byte;
  312.   StrN : string;
  313. begin
  314.    L := N + pred(length(StrS));
  315.    if L < length(StrT) then
  316.       L := length(StrT);
  317.    if L > 255 then
  318.       Overtype := copy(StrT,1,pred(N)) + copy(StrS,1,255-N)
  319.        else
  320.    begin
  321.       fillchar(StrN[1],L,' ');
  322.       StrN[0] := chr(L);
  323.       move(StrT[1],StrN[1],length(StrT));
  324.       move(StrS[1],StrN[N],length(StrS));
  325.       OverType := StrN;
  326.    end;
  327. end;  {OverType}
  328.  
  329. function Strip(L,C:char;Str:string):string;
  330. {L is left,center,right,all,ends}
  331. var I :  byte;
  332. begin
  333.    Case Upcase(L) of
  334.    'L' : begin       {Left}
  335.             while (Str[1] = C) and (length(Str) > 0) do
  336.                Delete(Str,1,1);
  337.          end;
  338.    'R' : begin       {Right}
  339.             while (Str[length(Str)] = C) and (length(Str) > 0) do
  340.                Delete(Str,length(Str),1);
  341.          end;
  342.    'B' : begin       {Both left and right}
  343.             while (Str[1] = C) and (length(Str) > 0) do
  344.                Delete(Str,1,1);
  345.             while (Str[length(Str)] = C) and (length(Str) > 0)  do
  346.                Delete(Str,length(Str),1);
  347.          end;
  348.    'A' : begin       {All}
  349.             I := 1;
  350.             repeat
  351.                if (Str[I] = C) and (length(Str) > 0) then
  352.                   Delete(Str,I,1)
  353.                else
  354.                   I := succ(I);
  355.             until (I > length(Str)) or (Str = '');
  356.          end;
  357.    end;
  358.    Strip := Str;
  359. end;  {Strip}
  360.  
  361. function LastPos(C:char;Str:string):byte;
  362. {}
  363. Var I : byte;
  364. begin
  365.    I := succ(Length(Str));
  366.    repeat
  367.       dec(I);
  368.    until (I = 0) or (Str[I] = C);
  369.    LastPos := I;
  370. end;  {LastPos}
  371.  
  372. function PosAfter(C:char;Str:string;Start:byte):byte;
  373. {}
  374. Var I : byte;
  375. begin
  376.    I := length(Str);
  377.    if (I = 0) or (Start > I) then
  378.       PosAfter := 0
  379.    else
  380.    begin
  381.       dec(Start);
  382.       repeat
  383.         inc(Start)
  384.       until (Start > I) or (Str[Start] = C);
  385.       if Start > I then
  386.          PosAfter := 0
  387.       else
  388.          PosAfter := Start;
  389.    end;
  390. end; {PosAfter}
  391.  
  392. function LastPosBefore(C:char;Str:string;Last:byte):byte;
  393. {}
  394. begin
  395.    Str := copy(Str,1,Last);
  396.    LastPosBefore := LastPos(C,Str);
  397. end; {LostPosBefore}
  398.  
  399. function LocWord(StartAT,Wordno:byte;Str:string):byte;
  400. {local proc used by PosWord and Extract word}
  401. var
  402.   W,L: integer;
  403.   Spacebefore: boolean;
  404. begin
  405.    if (Str = '') or (wordno < 1) or (StartAT > length(Str)) then
  406.    begin
  407.        LocWord := 0;
  408.        exit;
  409.    end;
  410.    SpaceBefore := true;
  411.    W := 0;
  412.    L := length(Str);
  413.    StartAT := pred(StartAT);
  414.    while (W < Wordno) and (StartAT <= length(Str)) do
  415.    begin
  416.       StartAT := succ(StartAT);
  417.       if SpaceBefore and (Str[StartAT] <> ' ') then
  418.       begin
  419.          W := succ(W);
  420.          SpaceBefore := false;
  421.       end
  422.       else
  423.          if (SpaceBefore = false) and (Str[StartAT] = ' ') then
  424.             SpaceBefore := true;
  425.    end;
  426.    if W = Wordno then
  427.       LocWord := StartAT
  428.    else
  429.       LocWord := 0;
  430. end;
  431.  
  432. function PosWord(Wordno:byte;Str:string):byte;
  433. begin
  434.    PosWord := LocWord(1,wordno,Str);
  435. end;  {Word}
  436.  
  437. function WordCnt(Str:string):byte;
  438. var
  439.   W,I: integer;
  440.   SpaceBefore: boolean;
  441. begin
  442.    if Str = '' then
  443.    begin
  444.       WordCnt := 0;
  445.       exit;
  446.    end;
  447.    SpaceBefore := true;
  448.    W := 0;
  449.    For  I :=  1 to length(Str) do
  450.    begin
  451.       if SpaceBefore and (Str[I] <> ' ') then
  452.       begin
  453.          W := succ(W);
  454.          SpaceBefore := false;
  455.       end
  456.       else
  457.          if (SpaceBefore = false) and (Str[I] = ' ') then
  458.             SpaceBefore := true;
  459.    end;
  460.    WordCnt := W;
  461. end;
  462.  
  463. function ExtractWords(StartWord,NoWords:byte;Str:string):string;
  464. var Start, finish : integer;
  465. begin
  466.    if Str = '' then
  467.    begin
  468.       ExtractWords := '';
  469.       exit;
  470.    end;
  471.    Start := LocWord(1,StartWord,Str);
  472.    if Start <> 0 then
  473.       finish := LocWord(Start,succ(NoWords),Str)
  474.    else
  475.    begin
  476.       ExtractWords := '';
  477.       exit;
  478.    end;
  479.    if finish = 0 then
  480.       finish := succ(length(Str));
  481.    repeat
  482.       finish := pred(finish);
  483.    until Str[finish] <> ' ';
  484.    ExtractWords := copy(Str,Start,succ(finish-Start));
  485. end;  {ExtractWords}
  486.  
  487. function ValidInt(Str:string):boolean;
  488. {}
  489. var 
  490.   Temp : longint;
  491.   Code : integer;
  492.  
  493.   function NoLetters:boolean;
  494.   var 
  495.     I:integer;
  496.     Bad: boolean;
  497.   begin
  498.      NoLetters := true;
  499.      for I := 1 to Length(Str) do
  500.      begin
  501.         if (Str[I] in ['0'..'9']) = false then
  502.            NoLetters := false;
  503.      end;
  504.   end;
  505.  
  506. begin
  507.    if length(Str) = 0 then
  508.       ValidInt := true
  509.    else
  510.    begin
  511.       val(Str,temp,code);
  512.       ValidInt := (Code = 0) and Noletters;
  513.    end;
  514. end; {ValidInt}
  515.  
  516. function ValidHEXInt(Str:string):boolean;
  517. {}
  518. var 
  519.   Temp : longint;
  520.   Code : integer;
  521. begin
  522.    if length(Str) = 0 then
  523.       ValidHEXInt := true
  524.    else
  525.    begin
  526.       val(Str,temp,code);
  527.       ValidHEXInt := (Code = 0);
  528.    end;
  529. end; {ValidHEXInt}
  530.  
  531. function IntToStr(Number:longint):string;
  532. {}
  533. var Temp : string;
  534. begin
  535.    Str(Number,temp);
  536.    IntToStr := temp;
  537. end; {IntToStr}
  538.  
  539. function IntToHEXStr(Number:longint):string;
  540. {}
  541. const
  542.    HEXChars: array [0..15] of char = '0123456789ABCDEF';
  543. var
  544.    I : integer;
  545.    Str : string;
  546.    BitsToShift: byte;
  547.    Chr : char;
  548. begin
  549.    Str := '';
  550.    for I := 7 downto 0 do
  551.    begin
  552.       BitsToShift := I*4;
  553.       Chr := HEXChars[ (Number shr BitsToShift) and $F];
  554.       if not ((Str = '') and (Chr = '0')) then
  555.          Str := Str + Chr;
  556.    end;
  557.    IntToHEXStr := Str;
  558. end; {IntToHEXStr}
  559.  
  560. function ValidReal(Str:string):boolean;
  561. {}
  562. var
  563.   Code : integer;
  564.   Temp : extended;
  565. begin
  566.    if length(Str) = 0 then
  567.       ValidReal := true
  568.    else
  569.    begin
  570.       if Copy(Str,1,1)='.' Then
  571.          Str:='0'+Str;
  572.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  573.          Insert('0',Str,2);
  574.       if Str[length(Str)] = '.' then
  575.          Delete(Str,length(Str),1);
  576.       val(Str,temp,code);
  577.       ValidReal := (Code = 0);
  578.    end;
  579. end; {ValidReal}
  580.  
  581. function StrToReal(Str:string):extended;
  582. var
  583.   code : integer;
  584.   Temp : extended;
  585. begin
  586.    if length(Str) = 0 then
  587.       StrToReal := 0
  588.    else
  589.    begin
  590.       if Copy(Str,1,1)='.' Then
  591.          Str:='0'+Str;
  592.       if (Copy(Str,1,1)='-') and (Copy(Str,2,1)='.') Then
  593.          Insert('0',Str,2);
  594.       if Str[length(Str)] = '.' then
  595.          Delete(Str,length(Str),1);
  596.       val(Str,temp,code);
  597.       if code = 0 then
  598.          StrToReal := temp
  599.       else
  600.          StrToReal := 0;
  601.    end;
  602. end; {StrToReal}
  603.  
  604. function RealToStr(Number:extended;Decimals:byte):string;
  605. var Temp : string;
  606. begin
  607.    Str(Number:20:Decimals,Temp);
  608.    repeat
  609.         if copy(Temp,1,1) = ' ' then delete(Temp,1,1);
  610.    until copy(temp,1,1) <> ' ';
  611.    if Decimals = Floating then
  612.    begin
  613.       Temp := Strip('R','0',Temp);
  614.       if Temp[Length(temp)] = '.' then
  615.          Delete(temp,Length(temp),1);
  616.    end;
  617.    RealToStr := Temp;
  618. end; {RealToStr}
  619.  
  620. function StrToInt(Str:string):integer;
  621. var temp,code : integer;
  622. begin
  623.    if length(Str) = 0 then
  624.       StrToInt := 0
  625.    else
  626.    begin
  627.       val(Str,temp,code);
  628.       if code = 0 then
  629.          StrToInt := temp
  630.       else
  631.          StrToInt := 0;
  632.    end;
  633. end; {StrToInt}
  634.  
  635. function StrToLong(Str:string):Longint;
  636. var
  637.   code : integer;
  638.   Temp : longint;
  639. begin
  640.    if length(Str) = 0 then
  641.       StrToLong := 0
  642.    else
  643.    begin
  644.       val(Str,temp,code);
  645.       if code = 0 then
  646.          StrToLong := temp
  647.       else
  648.          StrToLong := 0;
  649.    end;
  650. end; {StrToLong}
  651.  
  652. function HEXStrToLong(Str:string):longint;
  653. {}
  654. begin
  655.    if Str = '' then
  656.       HEXStrToLong := 0
  657.    else
  658.    begin
  659.       if Str[1] <> '$' then
  660.          Str := '$'+Str;
  661.       HEXStrtoLong := StrToLong(Str);
  662.    end;
  663. end; {HEXStrToLong}
  664.  
  665. function RealToSciStr(Number:extended; D:byte):string;
  666. {Credits: Michael Harris, Houston. Thanks!}
  667. Const
  668.     DamnNearUnity = 9.99999999E-01;
  669. Var
  670.     Temp : extended;
  671.     Power: integer;
  672.     Value: string;
  673.     Sign : char;
  674. begin
  675.    if Number = 1.0 then
  676.       RealToSciStr := '1.000'
  677.    else
  678.    begin
  679.       Temp := Number;
  680.       Power := 0;
  681.       if Number > 1.0 then
  682.       begin
  683.          while Temp >= 10.0 do
  684.          begin
  685.              Inc(Power);
  686.              Temp := Temp/10.0;
  687.          end;
  688.          Sign := '+';
  689.       end
  690.       else
  691.       begin
  692.          while Temp < DamnNearUnity do
  693.          begin
  694.              Inc(Power);
  695.              Temp := Temp * 10.0;
  696.          end;
  697.          Sign := '-';
  698.       end;
  699.       Value := RealToStr(Temp,D);
  700.       RealToSciStr := Value+'E'+Sign+Padright(IntToStr(Power),2,'0');
  701.    end;
  702. end; {RealToSciStr}
  703.  
  704. function NthNumber(InStr:string;Nth:byte) : char;
  705. {Returns the nth number in an alphanumeric string}
  706. var
  707.    Counter : byte;
  708.    B, Len : byte;
  709. begin
  710.     Counter := 0;
  711.     B := 0;
  712.     Len := Length(InStr);
  713.     Repeat
  714.          Inc(B);
  715.          If InStr[B] in ['0'..'9'] then
  716.             Inc(Counter);
  717.     Until (Counter = Nth) or (B >= Len);
  718.     If (Counter >= Len) and ( (InStr[Len] in ['0'..'9']) = false) then
  719.        NthNumber := #0
  720.     else
  721.        NthNumber := InStr[B];
  722. end; {NthNumber}
  723. {||||||||||||||||||||||||||||||||||||||||||||||||||}
  724. {                                                  }
  725. {   F O R M A T    O B J E C T    M E T H O D S    }
  726. {                                                  }
  727. {||||||||||||||||||||||||||||||||||||||||||||||||||}
  728. constructor FmtNumberOBJ.Init;
  729. {}
  730. begin
  731.    SetPrefixSuffix('','');
  732.    SetSign(Minus);
  733.    SetSeparators(' ',',','.');
  734.    SetJustification(JustLeft);
  735. end; {FmtNumberOBJ.Init}
  736.  
  737. procedure FmtNumberOBJ.SetPrefixSuffix(P,S:string);
  738. {}
  739. begin
  740.    vPrefix := P;
  741.    vSuffix := S;
  742. end; {FmtNumberOBJ.SetPrefixSuffix}
  743.  
  744. procedure FmtNumberOBJ.SetSign(S:tSign);
  745. {}
  746. begin
  747.    vSign := S;
  748. end; {FmtNumberOBJ.SetSign}
  749.  
  750. procedure FmtNumberOBJ.SetSeparators(P,T,D:char);
  751. {}
  752. begin
  753.    vPad := P;
  754.    vThousandsSep := T;
  755.    vDecimalSep := D;
  756. end; {FmtNumberOBJ.SetSeparators}
  757.  
  758. procedure FmtNumberOBJ.SetJustification(J:tJust);
  759. {}
  760. begin
  761.    vJustification := J;
  762. end; {FmtNumberOBJ.SetJustification}
  763.  
  764. function FmtNumberOBJ.GetDecimal:char;
  765. {}
  766. begin
  767.    GetDecimal := vDecimalSep;
  768. end; {FmtNumberOBJ.GetDecimal}
  769.  
  770. function FmtNumberOBJ.FormattedStr(StrVal:string; Width:byte):string;
  771. {}
  772. var
  773.    DP: integer;
  774.    Neg: boolean;
  775.    Temp,Unformatted: string;
  776. begin
  777.    Unformatted := StrVal;
  778.    if StrVal <> '' then
  779.    begin
  780.       if (StrVal[1] = '-') then
  781.       begin
  782.          Neg := true;
  783.          delete(StrVal,1,1);
  784.       end
  785.       else
  786.          Neg := false;
  787.       DP := pos('.',StrVal);
  788.       if DP = 0 then
  789.          DP := succ(length(StrVal))
  790.       else
  791.          if vDecimalSep <> '.' then
  792.             StrVal[DP] := vDecimalSep;
  793.       dec(DP,3);
  794.       while (DP > 1) and (vThousandsSep <> #0) do    {add thousands separator}
  795.       begin
  796.          insert(vThousandsSep,StrVal,DP);
  797.          dec(DP,3);
  798.       end;
  799.       if vPrefix <> '' then
  800.          StrVal := vPrefix + StrVal;
  801.       if vSuffix <> '' then
  802.          StrVal := StrVal + vSuffix;
  803.       if Neg then
  804.          case vSign of
  805.             PlusMinus, Minus:
  806.                StrVal := '-'+StrVal;
  807.             DbCr:
  808.                StrVal := StrVal + 'DB';
  809.             Brackets:
  810.                StrVal := '('+StrVal + ')';
  811.          end {case}
  812.       else
  813.          case vSign of
  814.             PlusMinus:
  815.                StrVal := '+'+StrVal;
  816.             DbCr:
  817.                StrVal := StrVal + 'CR';
  818.          end; {case}
  819.    end;
  820.    {now see if there is room for the formatted string}
  821.    Temp := Pad(JustRight,StrVal,succ(Width),vPad);
  822.    if Temp[1] = vPad then {there was room}
  823.       FormattedStr := Pad(vJustification,StrVal,Width,vPad)
  824.    else
  825.       FormattedStr := Pad(vJustification,Unformatted,Width,vPad);
  826. end; {FmtNumberOBJ.FormattedStr}
  827.  
  828. function FmtNumberOBJ.FormattedLong(Val:longint; Width:byte):string;
  829. {}
  830. var
  831.   Str:string;
  832. begin
  833.    Str := IntToStr(Val);
  834.    FormattedLong := FormattedStr(Str,Width);
  835. end; {FmtNumberOBJ.FormattedLong}
  836.  
  837. function FmtNumberOBJ.FormattedReal(Val:extended; DP:byte; Width:byte):string;
  838. {}
  839. var
  840.   Str:string;
  841. begin
  842.    Str := RealToStr(Val,DP);
  843.    FormattedReal := FormattedStr(Str,Width);
  844. end; {FmtNumberOBJ.FormattedReal}
  845.  
  846. destructor FmtNumberOBJ.Done;
  847. {}
  848. begin end;
  849. {|||||||||||||||||||||||||||||||||||||||||||||||}
  850. {                                               }
  851. {     U N I T   I N I T I A L I Z A T I O N     }
  852. {                                               }
  853. {|||||||||||||||||||||||||||||||||||||||||||||||}
  854.  
  855. procedure StrInit;
  856. {initilizes objects and global variables}
  857. begin
  858. end;
  859.  
  860. {end of unit - add initialization routines below}
  861. {$IFNDEF OVERLAY}
  862. begin
  863.    StrInit;
  864. {$ENDIF}
  865. end.
  866.