home *** CD-ROM | disk | FTP | other *** search
/ Delphi Programming Unleashed / Delphi_Programming_Unleashed_SAMS_Publishing_1995.iso / units / utilbox.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1995-03-21  |  4.3 KB  |  173 lines
  1. unit UtilBox;
  2.  
  3. interface
  4.  
  5. uses
  6.   WinTypes, WinProcs, Messages,
  7.   SysUtils, Controls;
  8.  
  9. function AddComma(S: string; MaxLen : Word): string;
  10. function WinExecAndWait(Path : Pchar; Visibility : word) : word;
  11. procedure YieldToOthers;
  12. function StrStripComma(S: PChar): PChar;
  13. function StrAddComma(S: PChar; MaxLen : Word): PChar;
  14. function PathToExe: string;
  15. procedure Center(var Child: TWinControl; Parent: TWinControl);
  16. implementation
  17.  
  18. uses
  19.   StrBox;
  20.  
  21. {----------------------------------------------------
  22.        Name: AddComma function
  23. Declaration: AddComma(S: string; MaxLen : Word): string;
  24.        Unit: UtilBox
  25.        Code: S
  26.        Date: 03/05/95
  27. Description: Add commas to monetary values or to plain
  28.              integers. Turn $234567 into $234,567
  29. -----------------------------------------------------}
  30.  
  31. function AddComma(S: string; MaxLen : Word): string;
  32. var
  33.   OffSet: Word;
  34.   MinLoc: Word;
  35.   NewLen: Word;
  36.   Value, Decimal: Integer;
  37.   SaveDec: string;
  38. begin
  39.   NewLen := Length(S);
  40.   OffSet := NewLen;
  41.   MinLoc := 4;
  42.   if (S[1] = '-') or (S[1] = '$') then Inc(MinLoc);
  43.   if (S[2] = '-') or (S[2] = '$') then Inc(MinLoc);
  44.   Decimal := Pos('.', S);
  45.   if Decimal <> 0 then begin
  46.     Move(S[Decimal], SaveDec[1], Succ(NewLen - Decimal));
  47.     SaveDec[0] := Chr(Succ(NewLen - Decimal));
  48.     S[0] := Chr(Pred(Decimal));
  49.     NewLen := Decimal;
  50.     OffSet := NewLen;
  51.   end else begin
  52.     SaveDec := '';
  53.     Inc(NewLen);
  54.     Inc(OffSet);
  55.   end;
  56.  
  57.   while (OffSet > MinLoc) and (NewLen < MaxLen) do begin
  58.     Dec(OffSet, 3);
  59.     Value := (NewLen - OffSet);
  60.     Inc(NewLen);
  61.     S[0] := Chr(Pred(NewLen));
  62.     Move(S[OffSet], S[Succ(OffSet)], Value);
  63.     S[OffSet] := ',';
  64.   end;
  65.  
  66.   AddComma := S + SaveDec;
  67. end;
  68.  
  69. { Center the child control in the Parent control. You may need
  70.   to typecast the Child control as a TWinControl before you
  71.   can make this call. }
  72. procedure Center(var Child: TWinControl; Parent: TWinControl);
  73. var
  74.   R: TRect;
  75. begin
  76.   TWinControl(Child).BoundsRect := TWinControl(Parent).ClientRect;
  77.   Child.Width := Child.Width - 10;
  78.   Child.Top := Child.Top + 5;
  79.   Child.Height := Child.Height - 10;
  80.   Child.Left := Child.Left + 5;
  81. end;
  82.  
  83. function PathToExe: string;
  84. var
  85.   S: string;
  86. begin
  87.   S := ParamStr(0);
  88.   Result := StripLastToken(S, '\') + '\';
  89. end;
  90.  
  91. {----------------------------------------------------
  92.        Name: WinExecAndWait function
  93. Declaration: WinExecAndWait(Path : Pchar; Visibility : word) : word;
  94.        Unit: UtilBox
  95.        Code: S
  96.        Date: 02/05/95
  97. Description: Execute a Windows program and wait until it
  98.              returns. In the meantime, continue to process
  99.              Window messages. ( Thanks to Lar Mader. )
  100. -----------------------------------------------------}
  101.  
  102. function WinExecAndWait(Path : Pchar; Visibility : word) : word;
  103. var
  104.   InstanceID : THandle;
  105.   Msg : TMSg;
  106. begin
  107.   InstanceID := WinExec(Path,Visibility);
  108.   if InstanceID < 32 then { a value less than 32 indicates an Exec error }
  109.      WinExecAndWait := InstanceID
  110.   else
  111.     repeat
  112.       while PeekMessage(Msg,0,0,0,PM_REMOVE) do begin
  113.         if Msg.Message = WM_QUIT then
  114.            halt(Msg.wParam);
  115.         TranslateMessage(Msg);
  116.         DispatchMessage(Msg);
  117.       end;
  118.     until GetModuleUsage(InstanceID) = 0;
  119. end;
  120.  
  121. procedure YieldToOthers;
  122. var
  123.   Msg : TMsg;
  124. begin
  125.   while PeekMessage(Msg,0,0,0,PM_REMOVE) do begin
  126.     if (Msg.Message = WM_QUIT) then begin
  127.       Halt;
  128.     end;
  129.     TranslateMessage(Msg);
  130.     DispatchMessage(Msg);
  131.   end;
  132. end;
  133.  
  134. { Needs more testing }
  135. function StrAddComma(S: PChar; MaxLen : Word): PChar;
  136. var
  137.   OffSet: Word;
  138.   MinLoc: Word;
  139.   NewLen: Word;
  140. begin
  141.   NewLen := StrLen(S);
  142.   OffSet := NewLen;
  143.   MinLoc := 3;
  144.   if S[1] = '-' then Inc(MinLoc);
  145.   while (OffSet > MinLoc) and (NewLen < MaxLen) do begin
  146.     Dec(OffSet, 3);
  147.     StrMove(S + Succ(OffSet), S + OffSet, Succ(NewLen - OffSet));
  148.     S[OffSet] := ',';
  149.     Inc(NewLen);
  150.   end;
  151.   StrAddComma := S;
  152. end;
  153.  
  154. { Needs more testing }
  155. function StrStripComma(S: PChar): PChar;
  156. var
  157.   P: PChar;
  158.   Len: Word;
  159. begin
  160.   StrStripComma := S;
  161.   Len := StrLen(S);
  162.   P := StrScan(S, ',');;
  163.   while P <> nil do begin
  164.     StrMove(P, P+1, Len - (P-S));
  165.     Dec(Len);
  166.     P := StrScan(P, ',');
  167.   end;
  168. end;
  169.  
  170.  
  171. end.
  172.  
  173.