moreutil.pas

Delphi direct support for GIF files

  {$I-}
  ChDir( dir);
  {$I+}
  if IOresult = 0
  then DirectoryExists := True
  else DirectoryExists := False;
  ChDir(currentdir);
end; { DirectoryExists }

function Elapsed: string;
{ Returns runtime in seconds }
var
  Period: double;
begin { Elapsed }
  Period := 86400 * (StopTime - StartTime);
  Elapsed := IntToStr(Round(Period));
end;  { Elapsed }

function ExtendedVersionStr: String;
{ Returns a string containing the name and the date of creation of the
  running program }
var
  Date, Name, Path, Ext: string;
begin { ExtendedVersionStr }
  FileNameSplit( paramstr( 0), Path, Name, Ext);
  Date := Versionstr;
  Result := 'Program ' + Name + ' - Version ' + Versionstr;
end; { ExtendedVersionStr }

{$ifdef ver80}
function ExtractFileDir( Spec: string): string;
begin
  result := SysUtils.ExtractFilePath( Spec);
end;

function ExtractFilePath( Spec: string): string;
begin
  result := ForceBackSlash(SysUtils.ExtractFilePath( Spec));
end;
{$endif ver80}

procedure FatalError(MessageStr: string);
{ Shows window with Str as message.
  Stops calling program. }
var
  ErrorForm: TWarningForm;
begin { FatalError }
  if BatchRun
  then Application.Terminate;
  ErrorForm := TWarningForm.Create(nil);
  ErrorForm.Error(MessageStr);
  ErrorForm.Free;
end;  { FatalError }

procedure FileNameSplit(Spec: string; var path, name, ext:string);
{ Returns separate parts of a file specification }
var
  len: longint;
  FullName: string;
begin { FileNameSplit }
  path := ExtractFilePath(Spec);
  ext := ExtractFileExt(Spec);
  FullName := ExtractFileName(Spec);
  len := length(FullName) - length(ext);
  name := copy(FullName, 1, len);
end; { FileNameSplit }

procedure FindCommonStrings(List1, List2: TStringlist;
                            var CommonStrings: TStringlist);
{ Returns in CommonStrings the stings that are present in
both List1 and List2 }
var Value: String;
    i: Integer;
begin { FindCommonStrings }
  CommonStrings := TStringlist.Create;
  for i := 1 to List1.Count
  do begin
    Value := List1[i-1];
    if List2.IndexOf(Value) <> -1
    then if CommonStrings.IndexOf(Value) = -1
    then CommonStrings.Add(Value);
  end;
  for i := 1 to List2.Count
  do begin
    Value := List2[i-1];
    if List1.IndexOf(Value) <> -1
    then if CommonStrings.IndexOf(Value) = -1
    then CommonStrings.Add(Value);
  end;
end;  { FindCommonStrings }

function FindString(substr, s: String; options: TFindOptions): Integer;
{ Finds substring in a string; options e.g.: whole word; case-sensitive }
const
  WordChars = ['a'..'z', 'A'..'Z', #128..#168];
var
  p, l: Integer;
  Found: Boolean;
begin { FindString }
  if not (foCaseSensitive in options)
  then begin
    substr := UpperCase(substr);
    s := UpperCase(s);
  end;
  if not (foWholeWord in options)
  then FindString := Pos(substr, s)
  else begin
    repeat
      Found := False;
      l := length(substr);
      p := Pos(substr, s);
      if p <> 0
      then begin
        Found := True;
        if p > 1
        then if s[p-1] in WordChars
             then Found := False;
        if p+l <= Length(s)
        then if s[p+l] in WordChars
             then Found := False;
        if not Found
        then s[p] := Chr(Ord(s[p])+1); { this trick makes Pos find the next
                                        occurrence when called next time }
      end
    until Found or (p=0);
    FindString := p;
  end;
end;  { FindString }

procedure FreeList(var List: TList);
{ Frees list List the objects it contains }
var
  ItemNo: Integer;
  Item: TObject;
begin { FreeList }
  for ItemNo := 1 to List.Count
  do begin
    Item := List[ItemNo-1];
    FreeObject(Item);
  end;
  FreeObject(List);
end;  { FreeList }

procedure FreeObject(var o);
{ Frees object p AND sets it to nil }
var p: TObject absolute o;
begin { FreeObject }
  p.Free;
  p := nil;
end;  { FreeObject }

function ForceBackslash(const DirName: String): String;
{ Adds a default backslash to a directory name if not already present }
begin { ForceBackslash }
  if (DirName = '') or not (DirName[Length(DirName)] in ['\', ':'])
  then ForceBackSlash := DirName + '\'
  else ForceBackslash := Dirname
end;  { ForceBackslash }

procedure GetIniPath(section, varname: String; var dir: String);
{ Finds path in .INI file }
var
  IniFile: TIniFile;
begin { GetIniPath }
  OpenIniFile(IniFile);
  dir := IniFile.ReadString(section, varname, '');
  dir := ForceBackSlash(dir);
  IniFile.Free;
end;  { GetIniPath }

procedure GetIniString(section, varname: String; var result: String);
{ Finds string value in .INI file }
var
  IniFile: TIniFile;
begin { GetIniPath }
  OpenIniFile(IniFile);
  Result := IniFile.ReadString(section, varname, '');
  IniFile.Free;
end;  { GetIniPath }

function LeftAlign(s: String; count: Integer): String;
{ Returns a string with length Count, with s at the left and
padded with spaces to the right }
begin { LeftAlign }
  if Length(s) > count
  then LeftAlign := Copy(s, 1, count)
  else LeftAlign := s + SpaceStr(count - Length(s))
end;  { LeftAlign }

function LeftStr(s: String; count: Integer): String;
begin
  LeftStr := Copy(s, 1, count)
end;  { LeftStr }


procedure OpenIniFile(var Inifile: TIniFile);
{ Opens the ini file of the 'current application'.
It is assumed to be at the same location as the executable }
var IniFilename: String;
begin { OpenIniFile }
  IniFilename := Application.Exename;
  IniFilename := ChangeFileExt(Inifilename, '.ini');
  IniFile := TIniFile.Create(IniFilename);
end;  { OpenIniFile }

procedure ReplaceChars(var S: String; FromCh, ToCh: Char);
{ Replaces characters in string that are equal to FromCh with
characters ToCh }
var p: Integer;
begin { ReplaceChars }
  for p := 1 to Length(S)
  do if S[p] = FromCh
     then S[p] := ToCh;
end;  { ReplaceChars }

function RightAlign(s: String; count: Integer): String;
{ Returns a string with length Count, with s at the right and
padded with spaces to the left }
begin { RightAlign }
  if Length(s) > count
  then RightAlign := Copy(s, count, Length(s)-count)
  else RightAlign := SpaceStr(count - Length(s)) + s
end;  { RightAlign }

function RightStr(s: String; count: Integer): String;
begin
  RightStr := Copy(s, Length(s)-count+1, count)
end;  { RightStr }

procedure RunDosCommand(CmdLine: String);
{ Runs Dos command as if it were started from the command line,
explicitly calling command.com }
var Result: Integer;
begin { RunDosCommand }
  CmdLine := 'command.com' + ' /C ' + Cmdline + Chr(0);
  Result := WinExec(@CmdLine[1], sw_minimize);
  if Result < 32
  then ShowMessage('Execution of command line' + CRLF +
                   LeftStr(CmdLine, Length(CmdLine)-1) + CRLF +
                   'failed. Error code:' + IntToStr(result));
end;  { RunDosCommand }

(*
procedure RunProgram(CmdLine: String);
{ Runs program as if it were started from the command line }
var
  ExecResult: Integer;
  Filename: array[0..100] of Char;
  p, H: Integer;
begin { RunProgram }
  CmdLine := Cmdline + Chr(0);
  ExecResult := WinExec(@CmdLine[1], sw_restore);
  if ExecResult < 32
  then ShowMessage('Execution of command line' + CRLF +
                   LeftStr(CmdLine, Length(CmdLine)-1) + CRLF +
                   'failed. Error code:' + IntToStr(ExecResult));
  {p := Pos(' ', CmdLine);
  CmdLine := LeftStr(CmdLine, p-1) + Chr(0);}
  Application.ProcessMessages;
  H := GetModuleHandle(@CmdLine[1]);
end;  { RunProgram }
*)

procedure RunProgram( CmdLine: String);
{ Runs program as if it were started from the command line }
begin
  CmdLine := Cmdline + Chr(0);
  if WinExec( @CmdLine[1], sw_ShowNormal) < 32
  then MessageDlg( 'Failed to execute ' + CmdLine, mtError, [mbOK], 0);
end;  { RunProgram }

procedure ShowMessage(message: String);
{ Same as Dialogs' ShowMessage, but sets the cursor to crDefault
before displaying the dialog and sets it back to what it was
afterwards }
var oldCursor: TCursor;
begin { ShowMessage }
  OldCursor := Screen.Cursor;
  Screen.Cursor := crDefault;
  Dialogs.ShowMessage(message);
  Screen.Cursor := OldCursor;
end;  { ShowMessage }

function SpaceStr(n: longint): string;
{ returns string containing n spaces (#32) }
var
  j: longint;
begin { SpaceStr }
  Result := '';
  for j := 1 to n do Result := Result + Space;
end; { SpaceStr }

procedure SplitStringAt(str: String; splitchar: Char;
                       var firstpart, secondpart: String);
{ Splits string at first splitchar;
 if splitchar is not found, firstpart:=str; secondpart:='' }
var p: Integer;
begin { SplitStringAt }
  p := Pos(splitchar, str);
  if p <> 0
  then begin
    firstpart := LeftStr(str, p-1);
    secondpart := RightStr(str, length(str)-p)
  end
  else begin
    firstpart := str;
    secondpart := ''
  end
end;  { SplitStringAt }

function StrToDateTime(S: string): TDateTime;
{ Same as SysUtils.StrToDateTime, but this one also permits
the use of the '/' (slash) date separator even if the
DateSeparator variable on this machine is not a slash }
var p: Integer;
    YStr, RestStr: String;
begin { StrToDateTime }
  if (DateSeparator <> '/') and (Pos(DateSeparator, S) = 0)
  then ReplaceChars(S, '/', DateSeparator);
  Result := SysUtils.StrToDateTime(S);
end;  { StrToDateTime }


function StrToFloat(const S: string): Extended;
{ See Help on StrToFloat for specification.
This wrapper is needed because for unknown reasons,
on some (Win95) systems StrToFloat gives exceptions
where it shouldn't }
var
  p: Integer;
  WorkS: String;
begin { StrToFloat }
  try
    Result := SysUtils.StrToFloat(S);
  except
    on EConvertError
    do begin
      WarningMessage('StrToFloat EConvertError; S='+S+CRLF
                     +'DecimalSeparator='+DecimalSeparator);
      WorkS := S;
      p := Pos(',', S);
      WorkS[p] := '.';
      p := Pos(',', S);
      if p = 0
      then Result := SysUtils.StrToFloat(WorkS);
    end;
  end
end;  { StrToFloat }


function ThreeDigitStr(n: Integer): String;
{ Makes a string of three digits representing the number 'n';
the number ought to lie in the interval [0, 999] }
var s: String;
begin { threedigitstr }
  Str(n, s);
  while Length(s) < 3
  do s := '0' + s;
  threedigitstr := s
end;  { threedigitstr }

procedure Trim(var s: String);
{ Eliminates leading and trailing spaces from a string }
begin { Trim }
  while Pos(' ', s) = 1
  do system.Delete(s, 1, 1);
  while (s <> '') and (s[Length(s)] = ' ')
  do system.Delete(s, Length(s), 1);
end;  { Trim }

function TwoDigitStr(n: Integer): String;
{ Makes a string of two digits representing the number 'n';
the number ought to lie in the interval [0, 99] }
var s: String;
begin { Twodigitstr }
  Str(n, s);
  if n < 10
  then TwoDigitStr := '0' + s
  else TwoDigitStr := s
end;  { Twodigitstr }

{$ifdef ver80}
procedure Sleep(msec: Longint);
const
  msecperday = 86400000; { = 24 * 3600 * 1000 }
var
  Start: TDateTime;
begin { Sleep }
  Start := Now;
  repeat Application.ProcessMessages
  until Now-Start > msec/msecperday
end;  { Sleep }
{$endif ver80}

function VersionStr: String;
{ Returns a string that represents the date of creation of the
  executable file of the program that's being executed }
const
  Month: array[1..12] of string =
    ('January', 'February', 'March', 'April', 'May', 'June', 'July',
     'August', 'September', 'October', 'November', 'December');
var
  DateTime: TDateTime;
  Filehandle, Filedate: longint;
  yy, mm, dd: word;
begin { VersionStr }
  Filehandle := FileOpen( ParamStr( 0), fmShareDenyNone);
  Filedate := FileGetDate( Filehandle);
  FileClose( Filehandle);
  DateTime := FileDateToDateTime( FileDate);
  DecodeDate( DateTime, yy, mm, dd);
  Result := IntToStr( dd) + ' ' + Month[mm] + ' ' + IntToStr( yy);
end;  { VersionStr }

procedure WarningMessage( Str: string);
{ Shows window with Str as message during 1 second.
  Calling program keeps running. }
begin { WarningMessage }
  if WarningForm = nil
  then WarningForm := TWarningForm.Create( nil);
  WarningForm.Warning( 1, Str);
end;  { WarningMessage }

function WithoutBackslash(const DirName: String): String;
{ Makes sure that a directory is not followed by a backslash,
with one exception: drive letter + ':\' is left unchanged }
begin { WithoutBackslash }
  if (Length(Dirname) = 0)
     or ((Length(Dirname) = 3) and (DirName[2]=':'))
     or (DirName[Length(Dirname)] <> '\')
  then Result := Dirname
  else Result := Copy(Dirname, 1, Length(Dirname)-1)
end;  { WithoutBackslash }

initialization
  WarningForm := nil;
{$ifndef ver80}
finalization
  WarningForm.Free;
{$endif ver80}
end.  { Unit MoreUtil }