unit SUtils;

interface

uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
     StdCtrls, Buttons, ExtCtrls, consts, ShellAPI, Registry, ShlObj,
     ActiveX, Math, ComCtrls, FileCtrl;

type
  TMachineInfo = record
    Platform: String;
    Version: String;
    Build: String;
    FullDesc: String;
  end;

function StrFill(inString: String; FillChar: Char; Lnth: Integer; Align: Char): String;
function LPad(inString: String; Padding: Integer): String;
function RPad(inString: String; Padding: Integer): String;
function GetPos(strVal: String; Delim: Char; CharPos: Integer): Integer;
function CountFields(strVal: String; Delim: Char): Integer;
function GetField(strVal: String; Delim: Char; FieldPos: Integer): String;
function InitCap(strVal: String): String;
function GetUserName: String;
function GetComputerName: String;
function GetMachineInfo: TMachineInfo;
function StrToReal(InValue: String): Real;
function RealToStr(InValue: Real; DecPlaces: Integer): String;
function Precision(InValue: Real; DecPlaces: Integer): Real;
procedure RefreshForm(FormName: TForm);
function ShellExec(Prog, FName, DefDir: String; Wait: Boolean): LongInt;
function ExecuteFile(const FileName, Params, DefaultDir: String; ShowCmd: Integer): THandle;
procedure SearchPathForFile(SearchFile: String; strList: TStrings; Status: TStatusBar);
function Encrypt(inString, Password: String): String;
function Decrypt(inString, Password: String): String;
function ShortenLabel(CurrForm: TForm; Value: String; Lnth: Integer): String;
function Matches(inString, Pattern: String): Boolean;
function ReformatDate(inDate: TDateTime): String;
function StrReplace(InString, FromSubStr, ToSubStr: String): String;
function IsAlpha(strVal: Char): Boolean;

implementation

function ShortenLabel(CurrForm: TForm; Value: String; Lnth: Integer): String;
var
     DirList: TStringList;
     i, cnt: Integer;
     Temp: String;
begin
     DirList := TStringList.Create;
     cnt := CountFields(Value, '\');
     for i := 1 to cnt do
        DirList.Add(GetField(Value, '\', i));

     with CurrForm.Canvas do begin
        if TextWidth(Value) <= Lnth then
           Result := Value
        else begin
           repeat
              Temp := ''; cnt := DirList.Count div 2;
              DirList.Delete(cnt);
              for i := 0 to DirList.Count - 1 do
                 if i = 0 then
                    Temp := DirList[i]
                 else
                    if i = cnt then
                       Temp := Temp + '\...'
                    else
                       Temp := Temp + '\' + DirList[i];
           until TextWidth(Temp) <= Lnth;
           Result := Temp;
        end;
     end;
     DirList.Free;
end;

function IsAlpha(strVal: Char): Boolean;
begin
     Result := False;
     if (strVal >= #65) and (strVal <= #90) then Result := True;
     if (strVal >= #97) and (strVal <= #122) then Result := True;
     if (strVal >= #48) and (strVal <= #57) then Result := True;
     if strVal = #95 then Result := True;
end;

function StrFill(inString: String; FillChar: Char; Lnth: Integer; Align: Char): String;
var
     i: Integer;
begin
     if UpperCase(Align) = 'L' then begin
        if Length(inString) > Lnth then begin
           inString := Copy(inString, 1, Lnth);
        end else begin
           for i := Length(inString) + 1 to Lnth do
              inString := inString + FillChar;
        end;
     end else begin
        if Length(inString) > Lnth then begin
           inString := Copy(inString, Length(inString) - Lnth + 1, Lnth);
        end else begin
           for i := 1 to Lnth - Length(inString) do
              inString := FillChar + inString;
        end;
     end;
     Result := inString;
end;

function LPad(inString: String; Padding: Integer): String;
var
     i: Integer;
begin
     if Length(inString) > Padding then begin
        inString := Copy(inString, 1, Padding);
     end else begin
        for i := Length(inString) + 1 to Padding do
           inString := inString + ' ';
     end;
     Result := inString;
end;

function RPad(inString: String; Padding: Integer): String;
var
     i: Integer;
begin
     if Length(inString) > Padding then begin
        inString := Copy(inString, 1, Padding);
     end else begin
        for i := Length(inString) + 1 to Padding do
           inString := ' ' + inString;
     end;
     Result := inString;
end;

function GetPos(strVal: String; Delim: Char; CharPos: Integer): Integer;
var
     i, counter, RetVal: Integer;
     flag: Boolean;
begin
     i := 1; counter := 0; RetVal := 0; flag := False;
     while not flag do begin
        if strVal[i] = Delim then begin
           counter := counter + 1;
           if counter = CharPos then begin
              RetVal := i;
              flag := True;
           end;
        end;
        i := i + 1;
        if i > Length(strVal) then flag := True;
     end;
     Result := RetVal;
end;

function CountFields(strVal: String; Delim: Char): Integer;
var
     i, counter: Integer;
begin
     counter := 0;
     for i := 1 to Length(strVal) do
        if strVal[i] = Delim then
           counter := counter + 1;
     Result := counter + 1;
end;

function GetField(strVal: String; Delim: Char; FieldPos: Integer): String;
var
     StartPos, EndPos, FieldCount: Integer;
     RetVal: String;
begin
     FieldCount := CountFields(strVal, Delim);
     if FieldPos > FieldCount then begin
        RetVal := '';
     end else begin
        if FieldPos = 1 then StartPos := 1
        else StartPos := GetPos(strVal, Delim, FieldPos - 1) + 1;
        if FieldPos = FieldCount then EndPos := Length(strVal)
        else EndPos := GetPos(strVal, Delim, FieldPos) - 1;
        RetVal := Copy(strVal, StartPos, EndPos - StartPos + 1);
     end;
     Result := RetVal;
end;

function InitCap(strVal: String): String;
var
     i: Integer;
     retVal: String;
begin
     retVal := retVal + UpperCase(Copy(strVal, 1, 1));
     for i := 2 to Length(strVal) do begin
        if (((strVal[i - 1] >= 'a') and (strVal[i - 1] <= 'z')) or
              ((strVal[i - 1] >= 'A') and (strVal[i - 1] <= 'Z'))) then
           retVal := retVal + LowerCase(Copy(strVal, i,1))
        else
           retVal := retVal + UpperCase(Copy(strVal, i, 1));
     end;
     Result := retVal;
end;

function GetUserName: String;
var
     posn: Integer;
     FKeys, FValues: TStringList;
     EnvStrings: PChar;
     UserName, s: String;
     Reg: TRegistry;
     MachineInfo: TMachineInfo;
begin
     MachineInfo := GetMachineInfo;
     if MachineInfo.Platform = 'Windows 95/98' then begin
        Reg := TRegistry.Create;
        try
           Reg.RootKey := HKEY_LOCAL_MACHINE;
           if Reg.KeyExists('Network\Logon') then begin
              Reg.OpenKey('Network\Logon', False);
              UserName := Reg.ReadString('username');
           end else begin
              UserName := 'Unknown';
           end;
        finally
           Reg.Free;
        end;
     end else begin
        FKeys := TStringList.Create;
        FValues := TStringList.Create;

        {$IFDEF WIN32}
           EnvStrings := GetEnvironmentStrings;
        {$ELSE}
           EnvStrings := GetDosEnvironment;
        {$ENDIF}

        while EnvStrings[0] <> #0 do begin
           s := StrPas(EnvStrings);
           FKeys.Add(Copy(s, 1, Pos('=', s) - 1));
           FValues.Add(Copy(s, Pos('=', s) + 1, 255));
           Inc(EnvStrings, StrLen(EnvStrings) + 1);
        end;

        posn := FKeys.IndexOf('USERNAME');
        if posn > -1 then
           UserName := FValues[posn]
        else
           UserName := 'Unknown';

        FKeys.Free;
        FValues.Free;
     end;
     Result := UserName;
end;

function GetComputerName: String;
var
     posn: Integer;
     FKeys, FValues: TStringList;
     EnvStrings: PChar;
     ComputerName, s: String;
     Reg: TRegistry;
     MachineInfo: TMachineInfo;
begin
     MachineInfo := GetMachineInfo;
     if MachineInfo.Platform = 'Windows 95/98' then begin
        Reg := TRegistry.Create;
        try
           Reg.RootKey := HKEY_LOCAL_MACHINE;
           if Reg.KeyExists('System\CurrentControlSet\Control\ComputerName\ComputerName') then begin
              Reg.OpenKey('System\CurrentControlSet\Control\ComputerName\ComputerName', False);
              ComputerName := Reg.ReadString('ComputerName');
           end else begin
              ComputerName := 'Unknown';
           end;
        finally
           Reg.Free;
        end;
     end else begin
        FKeys := TStringList.Create;
        FValues := TStringList.Create;

        {$IFDEF WIN32}
           EnvStrings := GetEnvironmentStrings;
        {$ELSE}
           EnvStrings := GetDosEnvironment;
        {$ENDIF}

        while EnvStrings[0] <> #0 do begin
           s := StrPas(EnvStrings);
           FKeys.Add(Copy(s, 1, Pos('=', s) - 1));
           FValues.Add(Copy(s, Pos('=', s) + 1, 255));
           Inc(EnvStrings, StrLen(EnvStrings) + 1);
        end;

        posn := FKeys.IndexOf('COMPUTERNAME');
        if posn > -1 then
           ComputerName := FValues[posn]
        else
           ComputerName := 'Unknown';

        FKeys.Free;
        FValues.Free;
     end;
     Result := ComputerName;
end;

function GetMachineInfo: TMachineInfo;
var
     OSVersion: TOSVersionInfoA;
     MachineInfo: TMachineInfo;
begin
     OSVersion.dwOSVersionInfoSize := SizeOf(TOSVersionInfoA);
     if GetVersionEx(OSVersion) then begin
        MachineInfo.Version := IntToStr(OSVersion.dwMajorVersion) + '.' +
                                IntToStr(OSVersion.dwMinorVersion);

        case OSVersion.dwPlatformId of
           0: MachineInfo.Platform := 'Windows 3.x';
           1: MachineInfo.Platform := 'Windows 95/98';
           2: MachineInfo.Platform := 'Windows NT';
        end;

        if OSVersion.dwBuildNumber <> 67766222 then
           if Trim(StrPas(OSVersion.szCSDVersion)) <> '' then
              MachineInfo.Build := '(Build ' + IntToStr(OSVersion.dwBuildNumber) +
                                    ' ' + StrPas(OSVersion.szCSDVersion) + ')'
           else
              MachineInfo.Build := '(Build ' + IntToStr(OSVersion.dwBuildNumber) + ')'
        else
           if Trim(StrPas(OSVersion.szCSDVersion)) <> '' then
              MachineInfo.Build := '(' + Trim(StrPas(OSVersion.szCSDVersion)) + ')'
           else
              MachineInfo.Build := '';

        MachineInfo.FullDesc := Trim(MachineInfo.Platform + ' ' +
                                MachineInfo.Version + MachineInfo.Build);
     end else begin
        MachineInfo.Platform := 'Unknown';
        MachineInfo.Version := '';
        MachineInfo.Build := '';
        MachineInfo.FullDesc := '';
     end;
     Result := MachineInfo;
end;

function StrToReal(InValue: String): Real;
var
     temp: String;
     i: Integer;
begin
     temp := '';
     for i := 1 to Length(InValue) do
        if ((Ord(InValue[i]) >= 48) and (Ord(InValue[i]) <=57)) or (InValue[i] = '.') then
           temp := temp + InValue[i];
     Result := StrToFloat(temp);
end;

function RealToStr(InValue: Real; DecPlaces: Integer): String;
var
     strInt, strDec, Junk: String;
     i: Integer;
     Ok: Boolean;
begin
     strInt := GetField(FloatToStr(InValue), '.', 1);
     strDec := GetField(FloatToStr(InValue), '.', 2);
     Ok := False;
     if (Length(strDec) > DecPlaces) then
        if (StrToInt(strDec[DecPlaces + 1]) >= 5) then
           Ok := True;

     strDec := StrFill(strDec, '0', DecPlaces, 'L');
     if Ok and (DecPlaces > 0) then begin
        if Length(IntToStr((StrToInt(strDec) + 1))) > DecPlaces then
           strInt := IntToStr(StrToInt(strInt) + 1);
        strDec := StrFill(IntToStr(StrToInt(strDec) + 1), '0', DecPlaces, 'R');
     end;

     Junk := strInt[Length(strInt)];
     for i := Length(strInt) - 1 downto 1 do
        if (Length(strInt) - i) mod 3 = 0 then
           Junk := strInt[i] + ',' + Junk
        else
           Junk := strInt[i] + Junk;

     if DecPlaces > 0 then
        Result := Junk + '.' + strDec
     else
        Result := Junk;
end;

function Precision(InValue: Real; DecPlaces: Integer): Real;
var
     intInt, intDec: Real;
     strDec: String;
     Ok: Boolean;
begin
     if DecPlaces = 0 then
        Result := Round(InValue)
     else begin
        intInt := Int(InValue);
        intDec := Frac(InValue);
        strDec := FormatFloat('######0', intDec);

        Ok := False;
        if (Length(strDec) > DecPlaces) then
           if (StrToInt(strDec[DecPlaces + 1]) >= 5) then
              Ok := True;

        strDec := StrFill(strDec, '0', DecPlaces, 'L');
        if Ok then begin
           if Length(IntToStr((StrToInt(strDec) + 1))) > DecPlaces then
              intInt := intInt + 1;
           strDec := StrFill(IntToStr(StrToInt(strDec) + 1), '0', DecPlaces, 'R');
        end;
        Result := intInt + (StrToInt(strDec) / Power(10, DecPlaces))
     end;
end;

procedure RefreshForm(FormName: TForm);
var
     i: Integer;
begin
     with FormName do begin
        for i := 0 to ComponentCount - 1 do
           if Components[i] is TWinControl then
              with Components[i] as TWinControl do
                 Refresh;
        Refresh;
     end;
end;

function ShellExec(Prog, FName, DefDir: String; Wait: Boolean): LongInt;
var
     Ok: Boolean;
     Sei: TShellExecuteInfo;
begin
     FillChar(Sei, SizeOf(Sei), Chr(0));
     Sei.cbSize := SizeOf(Sei);
     Sei.fMask := SEE_MASK_NOCLOSEPROCESS;
     Sei.lpVerb := PChar('open');
     Sei.lpFile := PChar(Prog);
     Sei.lpParameters := PChar(FName);
     Sei.lpDirectory := PChar(DefDir);
     Sei.nShow := SW_SHOW;

     Ok := Boolean(ShellExecuteEx(@Sei));
     if Ok then begin
        if Wait then begin
           while WaitForSingleObject(Sei.hProcess, 100) = WAIT_TIMEOUT do
              Application.ProcessMessages;
           Ok := GetExitCodeProcess(Sei.hProcess, DWord(Result));
        end else
           Result := 0;
     end;
     if not Ok then Result := -1;
end;

function ExecuteFile(const FileName, Params, DefaultDir: String; ShowCmd: Integer): THandle;
var
     zFileName: array[0..255] of Char;
begin
     if (DefaultDir <> '') and DirectoryExists(DefaultDir) then
        ChDir(DefaultDir);

     StrPCopy(zFileName, FileName + ' ' + Params);
     Result := WinExec(zFileName, SW_SHOWNORMAL);
end;

procedure SearchPathForFile(SearchFile: String; strList: TStrings; Status: TStatusBar);
var
     SearchRec: TSearchRec;
     FileName, FilePath: String;
begin
     FileName := ExtractFileName(SearchFile);
     FilePath := ExtractFilePath(SearchFile);
     if FilePath = '' then FilePath := GetCurrentDir;
     if FilePath[Length(FilePath)] <> '\' then FilePath := FilePath + '\';

     if FindFirst(SearchFile, faAnyFile, SearchRec) = 0 then begin
        repeat
           if (strList <> nil) and ((SearchRec.Attr and faDirectory) <> faDirectory) then begin
              try
                 strList.Add(FilePath + SearchRec.Name);
              except
                 {*};
              end;
           end;
           Application.ProcessMessages;
        until FindNext(SearchRec) <> 0;
     end;

     if FindFirst(FilePath + '*.*', faDirectory, SearchRec) = 0 then begin
        repeat
           if ((SearchRec.Attr and faDirectory) = faDirectory) and
                                          (SearchRec.Name[1] <> '.') then begin
              SearchPathForFile(FilePath + SearchRec.Name + '\' + FileName, strList, Status);
              if Status <> nil then begin
                 try
                    Status.SimpleText := FilePath + SearchRec.Name;
                 except
                    {*};
                 end;
              end;
           end;
           Application.ProcessMessages;
        until FindNext(SearchRec) <> 0;
     end;
     FindClose(SearchRec);
end;

function Decrypt(inString, Password: String): String;
var
     x, i, sText, sPW: Integer;
     Text, PW: PChar;
begin
     sText := Length(inString) + 1;
     sPW := Length(Password) + 1;
     GetMem(Text, sText);
     GetMem(PW, sPW);
     StrPCopy(Text, inString);
     StrPCopy(PW, Password);
     x := 0;
     for i := 0 to sText - 2 do begin
       Text[i] := Chr(Ord(Text[i]) - Ord(PW[x]));
       Inc(x);
       if x = (sPW - 1) then x := 0;
     end;
     Result := StrPas(Text);
     FreeMem(Text);
     FreeMem(PW);
end;

function Encrypt(inString, Password: String): String;
var
     x, i, sText, sPW: Integer;
     Text, PW: PChar;
begin
     sText := Length(inString) + 1;
     sPW := Length(Password) + 1;
     GetMem(Text, sText);
     GetMem(PW, sPW);
     StrPCopy(Text, inString);
     StrPCopy(PW, Password);
     x := 0;
     for i := 0 to sText - 2 do begin
        Text[i] := Chr(Ord(Text[i]) + Ord(PW[x]));
        Inc(x);
        if x = (sPW - 1) then x := 0;
     end;
     Result := StrPas(Text);
     FreeMem(Text);
     FreeMem(PW);
end;

function Matches(inString, Pattern: String): Boolean;
var
     i: Integer;
begin
     Result := False;
     Pattern := UpperCase(Pattern);
     if Length(Pattern) <> Length(inString) then Exit;
     for i := 1 to Length(Pattern) do begin
        case Pattern[i] of
           'N': if (inString[i] < '0') or (inString[i] > '9') then Exit;
           'A': if (UpperCase(inString[i]) < 'A') or (UpperCase(inString[i]) > 'Z') then Exit;
           'X': if ((UpperCase(inString[i]) < 'A') or (UpperCase(inString[i]) > 'Z')) and ((inString[i] < '0') or (inString[i] > '9')) then Exit;
           else if inString[i] <> Pattern[i] then Exit;
        end;
     end;
     Result := True;
end;

function ReformatDate(inDate: TDateTime): String;
var
     weekday, day, month, year: String;
begin
     weekday := FormatDateTime('dddd', inDate);
     day := FormatDateTime('d', inDate);
     month := FormatDatetime('mmmm', inDate);
     year := FormatDateTime('yyyy', inDate);
     case StrToInt(day) of
        1: day := '1st';
        2: day := '2nd';
        3: day := '3rd';
        21: day := '21st';
        22: day := '22nd';
        23: day := '23rd';
        31: day := '31st';
        else day := day + 'th';
     end;
     Result := weekday + ', ' + day + ' ' + month + ' ' + year;
end;

function StrReplace(InString, FromSubStr, ToSubStr: String): String;
var
     posn: Integer;
begin
     Result := InString;
     while Pos(FromSubStr, Result) > 0 do begin
        posn := Pos(FromSubStr, Result);
        Result := Copy(Result, 1, posn - 1) + ToSubStr +
                Copy(Result, posn + Length(FromSubStr), Length(Result) - (posn - 1));
     end;
end;

end.