{$D-}

Unit Disk;



interface

{***************************************************************************}

{***************************************************************************}



Function  AssignReset(var TF: text; FileStr: string): boolean;

Function  DataByte(OpChar: char; FileStr: string; PosNum: longint;

            var ByteVal: byte): boolean;

Function  Dir(DirStr: string): integer;

Function  DirDirs(DirStr: string): integer;

Function  DirExists(DirStr: string): boolean;

Function  DirExistsMake(DirStr: string): boolean;

procedure DirFiles(SearchStr: string; var Count: integer);

Function  DirKill(DirStr: string): integer;

Function  DirKillDef(DirStr: string): integer;

Function  DirMake(DirStr: string): boolean;

Procedure FileCopy(OriginalFile: string; NewFile: string);

Function  FileCreate(NewFile: string): boolean;

Function  FileDataBool(OpChar: char; FileStr: string; PosNum: longint;

            var BoolVal: boolean): boolean;

procedure FileDel(FileSpec: string; var Code: integer);

function  FileExists(FileStr: string): boolean;

function  FileExistsMake(FileStr: string): boolean;

Function  FileKill(DeadFile: string): integer;

Function  FileKillDef(DeadFile: string): integer;

Function  FileLine(ModeChar: char; FileStr: string;

            LineNum: integer; var LineStr: string): boolean;

Function  FileLineCount(FileStr: string): integer;

Function  FileLineDel(FileStr: string; StartNum, StopNum: integer): boolean;

Function  FileOpen(ModeChar:char; InFileStr:string;

            var InFile:text): integer;

Function  FileSearch(ModeChar: char; FileStr: string;

            var MatchStr: string): integer;

Function  FileSizeAny(FileStr: string): longint;

function  GetDirFile(SearchStr: string): string;

function  GetDirFileOnly(SearchStr: string): string;

procedure GetFileName(var Lead8, Ext: string);

Function  LineAppend(FileStr, InStr: string): boolean;

Function  LineRead(FileStr:string; Line: integer; var InStr:string): boolean;

Function  LineWrite(FileStr: string; Line: integer; InStr: string): boolean;

Procedure SayFile(SayFileStr: string);

procedure SplitFileName(InFile: string; var Lead8, Extension: string);



implementation

{***************************************************************************}

{***************************************************************************}

Uses

  Crt,

  Data,

  Dos,

  Glob,

  IOPorts, {* fix this! this is BBS specific for Say & SayL *}

  Keyb,

  Misc,

  Scrn;



const

  TempFile = 'TempFile.TMP';



Function  AssignReset(var TF: text; FileStr: string): boolean;

{***************************************************************************}

var

  Temp: boolean;

begin

  Assign(TF, FileStr);

{$I-}

  Reset(TF);

{$I+}

  Temp := IOResult = 0;

  if not(Temp) then

    ErrSayL('ERROR:  file '+FileStr+' would not reset!');

  AssignReset := Temp;

end;



Function DataByte(OpChar: char; FileStr: string; PosNum: longint;

           var ByteVal: byte): boolean;

{***************************************************************************}

var

  Temp: boolean;

  F: file of byte;

  alpha: longint;

begin

{$I-}

  Temp := true;

  case OpChar of

    'R':

      begin

        Assign(F, FileStr);

        Reset(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            Read(F, ByteVal);

            Temp := IOResult = 0;

          end

        else

          Temp := false;

        Close(F);

      end;

    'W':

      begin

        Assign(F, FileStr);

        Reset(F);

        if IOResult = 2 then

          Rewrite(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            write(F, ByteVal);

          end

        else

          begin

            Seek(F, FileSize(F));

            DumByte := 0;

            for alpha := 1 to PosNum - FileSize(F) do

              write(F, DumByte);

            write(F, ByteVal);

          end;

        Close(F);

      end;

  end; {* case *}

  Temp := (IOResult = 0) and Temp;

  DataByte := Temp;

{$I+}

end;



Function Dir(DirStr: string): integer;

{***************************************************************************}

var

  count: integer;

  S: SearchRec;

begin

  count := 0;

  FindFirst(DirStr, AnyFile, S);

  while DosError <> 18 do

    begin

      writeln(S.Name);

      Inc(Count);

      FindNext(S);

    end;

  Dir := Count;

end;



Function DirDirs(DirStr: string): integer;

{***************************************************************************}

var

  count: integer;

  S: SearchRec;

begin

  count := 0;

  FindFirst(DirStr, AnyFile, S);

  while DosError <> 18 do

    begin

      if (S.Attr and Directory = Directory) and

        ((S.Name <> '.') and (S.Name <> '..')) then

          begin

            if (Count mod 4 = 0) and (Count <> 0) then

              writeln;

            GotoXY((Count mod 4)*20, WhereY);

            write(S.Name);

            Inc(Count);

          end;

      FindNext(S);

    end;

  if count <> 0 then

    writeln;

  DirDirs := Count;

end;



Function DirExists(DirStr: string): boolean;

{***************************************************************************}

var

  S: SearchRec;

begin

  S.Name := '';

  FindFirst(DirStr, Directory, S);

  if S.Name <> '' then

    DirExists := true

  else

    DirExists := false;

end;



function  DirExistsMake(DirStr: string): boolean;

{***************************************************************************}

var

  Temp: boolean;

begin

  Temp := true;

  if not(DirExists(DirStr)) then

    Temp := DirMake(DirStr);

  DirExistsMake := Temp;

end;





procedure DirFiles(SearchStr: string; var Count: integer);

{***************************************************************************}

var

  DirInfo: SearchRec;

begin

  writeln('Directory of all "',SearchStr,'".');

  Count := 0;

  FindFirst(SearchStr,AnyFile,DirInfo);

  while DosError = 0 do

    begin

      if DirInfo.Attr <> 16 then

        begin

          GotoXY((Count mod 4)*20, WhereY);

          Inc(Count);

          Write(Count,') ',DirInfo.Name);

          if Factorial(Count, 4) then

            writeln;

        end;

      FindNext(DirInfo);

    end;

  if WhereX <> 1 then

    writeln;

end;



Function  DirKill(DirStr: string): integer;

{***************************************************************************}

begin

  {$I-}

  RmDir(DirStr);

  {$I+}

  DirKill := IOResult;

end;



Function  DirKillDef(DirStr: string): integer;

{***************************************************************************}

var

  DirResult: integer;

  S: SearchRec;

begin

  DirResult := DirKill(DirStr);

  if DirResult = 5 then

    begin

      FindFirst(DirStr+'\*.*', $3F, S);

      repeat

        if S.Attr and $10 = $10 then {* directory *}

          begin

            if (S.Name <> '.') and (S.Name <> '..') then

              DumInt := DirKillDef(DirStr + '\' + S.Name);

          end

        else

          DirResult := FileKillDef(DirStr + '\' + S.Name);

        FindNext(S);

      until DosError = 18; {* no more files *}

      DirResult := DirKill(DirStr);

    end;

  DirKillDef := DirResult;

end;



Function  DirMake(DirStr: string): boolean;

{***************************************************************************}

{* Will create multi-level directories with one call.

{***************************************************************************}

var

  SaveDir: string;

  DirChar: char;

  WorkDir: string;

begin

  GetDir(0, SaveDir);

  while DirStr <> '' do

    begin

      WorkDir := '';

      repeat

        DirChar := DirStr[1];

        DirStr := copy(DirStr, 2, length(DirStr) - 1);

        if DirChar <> '\' then

          WorkDir := WorkDir + DirChar;

      until (DirChar = '\') or (length(DirStr) = 0);

      {$I-}

      MkDir(WorkDir);

      if DirStr <> '' then

        ChDir(WorkDir);

      {$I+}

    end;

  DumInt := IOResult;

  {$I-}

  ChDir(SaveDir);

  {$I+}

  if IOResult = 0 then

    DirMake := true

  else

    DirMake := false;

end;



Procedure FileCopy(OriginalFile: string; NewFile: string);

{***************************************************************************}

var

  Orig,

  NewF: text;

  LineStr: string;

begin

  if FileOpen('R', OriginalFile, Orig) = 0 then

    if FileOpen('W', NewFile, NewF) = 0 then

      begin

        while not(EOF(Orig)) do

          begin

            readln(Orig, LineStr);

            writeln(NewF, LineStr);

          end;

        close(Orig);

        close(NewF);

      end;

end;



Function FileCreate(NewFile: string): boolean;

{***************************************************************************}

var

  NF: text;

begin

  if FileOpen('W', NewFile, NF) = 0 then

    begin

      close(NF);

      FileCreate := true;

    end

  else

    begin

      FileCreate := false;

      ErrSayL(#7+'ERROR:  unable to create file ' + NewFile + '!');

    end;

end;



Function FileDataBool(OpChar: char; FileStr: string; PosNum: longint;

           var BoolVal: boolean): boolean;

{***************************************************************************}

var

  Temp: boolean;

  F: file of boolean;

  alpha: longint;

begin

{$I-}

  Temp := true;

  case OpChar of

    'R':

      begin

        Assign(F, FileStr);

        Reset(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            Read(F, BoolVal);

            Temp := IOResult = 0;

          end

        else

          Temp := false;

        Close(F);

      end;

    'W':

      begin

        Assign(F, FileStr);

        Reset(F);

        if IOResult = 2 then

          Rewrite(F);

        if PosNum <= FileSize(F) then

          begin

            Seek(F, PosNum);

            write(F, BoolVal);

          end

        else

          begin

            DumBool := false;

            Seek(F, FileSize(F));

            for alpha := 1 to PosNum - FileSize(F) do

              write(F, DumBool);

            write(F, BoolVal);

          end;

        Close(F);

      end;

  end; {* case *}

  Temp := (IOResult = 0) and Temp;

  FileDataBool := Temp;

{$I+}

end;



procedure FileDel(FileSpec: string; var Code: integer);

{***************************************************************************}

{* page 147 Turbo Pascal Programmer's Toolkit by Rugg and Feldman

{***************************************************************************}

var

  Reg: registers;

begin

  FileSpec := FileSpec + chr(0);

  Reg.DX := ofs(FileSpec[1]);

  Reg.DS := seg(FileSpec[1]);

  Reg.AX := $4100;

  msdos(Reg);

  Code := Lo(Reg.Ax);

  if (Reg.Flags and $01) = 0 then

    Code := 0;

end;



function  FileExists(FileStr: string): boolean;

{***************************************************************************}

var

  S:  SearchRec;

begin

  S.Name := '';

  FindFirst(FileStr, AnyFile, S);

  if S.Name = '' then

    FileExists := false

  else

    FileExists := true;

end;



Function  FileExistsMake(FileStr: string): boolean;

{***************************************************************************}

var

  Temp: boolean;

begin

  Temp := FileExists(FileStr);

  if not(Temp) then

    Temp := FileCreate(FileStr);

  FileExistsMake := Temp;

end;



Function FileKill(DeadFile: string): integer;

{***************************************************************************}

var

  DF: text;

begin

  Assign(DF, DeadFile);

  {$I-}

  Erase(DF);

  {$I+}

  FileKill := IOResult;

end;



Function FileKillDef(DeadFile: string): integer;

{***************************************************************************}

var

  DF: text;

begin

  Assign(DF, DeadFile);

  {$I-}

  SetFAttr(DF, 0);

  Erase(DF);

  {$I+}

  FileKillDef := IOResult;

end;



Function  FileLine(ModeChar: char; FileStr: string; LineNum: integer;

            var LineStr: string): boolean;

{***************************************************************************}

var

  alpha: integer;

  InStr: string;

  TF,

  InFile: text;

  Temp: boolean;

begin

  Temp := true;

  ModeChar := upcase(ModeChar);

  if FileOpen('R', FileStr, InFile) <> 0 then

    begin

      if ModeChar = 'O' then

        begin

          if FileCreate(FileStr) then

            begin

              if FileOpen('R', FileStr, InFile) <> 0 then

                begin

                  FileLine := false;

                  exit;

                end;

            end

          else

            begin

              FileLine := false;

              exit;

            end;

        end

      else

        begin

          FileLine := false;

          exit;

        end;

    end;

  if FileOpen('W', TempFile, TF) <> 0 then

    begin

      close(InFile);

      FileLine := false;

      exit;

    end;

  case ModeChar of

    'R': {* Read a line *}

      begin

        close(TF);

        for alpha := 1 to LineNum do

          begin

            Temp := Temp and not(EOF(InFile));

            if Temp then

              readln(InFile, LineStr);

          end;

        Temp := Temp and (IOResult = 0);

        close(InFile);

      end;

    'D': {* Delete *}

      begin

        alpha := 0;

        repeat

          inc(alpha);

          readln(InFile, InStr);

          if alpha <> LineNum then

            writeln(TF, InStr);

        until EOF(InFile);

        close(InFile);

        close(TF);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    'I': {* Insert *}

      begin

        for alpha := 1 to LineNum - 1 do

          begin

            if EOF(InFile) then

              InStr := ''

            else

              readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        writeln(TF, LineStr);

        while not(EOF(InFile)) do

          begin

            readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        close(TF);

        close(InFile);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    'O': {* Overwrite *}

      begin

        for alpha := 1 to LineNum - 1 do

          begin

            if EOF(InFile) then

              InStr := ''

            else

              readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        if not(EOF(InFile)) then

          readln(InFile, DumStr);

        writeln(TF, LineStr);

        while not(EOF(InFile)) do

          begin

            readln(InFile, InStr);

            writeln(TF, InStr);

          end;

        close(TF);

        close(InFile);

        Erase(InFile);

        Rename(TF, FileStr);

      end;

    else

      begin

        SayL(Beep+'Function Text Line used improperly!');

        FileLine := false;

        exit;

      end;

  end; {case}

  Temp := Temp and (IOResult = 0);

  FileLine := Temp;

end;



Function  FileLineCount(FileStr: string): integer;

{***************************************************************************}

var

  TempFileLineCount: integer;

  FS: text;

begin

  TempFileLineCount := -1;

  if FileOpen('R', FileStr, FS) = 0 then

    begin

      TempFileLineCount := 0;

      while not(EOF(FS)) do

        begin

          readln(FS);

          inc(TempFileLineCount);

        end;

      close(FS);

    end;

  FileLineCount := TempFileLineCount;

end;



Function  FileLineDel(FileStr: string; StartNum, StopNum: integer): boolean;

{***************************************************************************}

var

  FS,

  TF: text;

  Line: integer;

  InStr: string;

  Temp: boolean;

begin

  if (StartNum <= 0) or (StopNum < StartNum) then

    begin

      FileLineDel := false;

      exit;

    end;

  Assign(FS, FileStr);

{$I-}

  Reset(FS);

  Assign(TF, TempFile);

  Rewrite(TF);

  Line := 0;

  while not(EOF(FS)) do

    begin

      readln(FS, InStr);

      Inc(Line);

      if (Line < StartNum) or (Line > StopNum) then

        writeln(TF, InStr);

    end;

  close(FS);

  close(TF);

  if IOResult = 0 then

    begin

      erase(FS);

      rename(TF, FileStr);

{$I+}

      Temp := IOResult = 0;

    end

  else

    Temp := false;

  FileLineDel := Temp;

end;



Function FileOpen(ModeChar:char; InFileStr:string; var InFile:text): integer;

{***************************************************************************}

var

  Dir: DirStr;

  Name: NameStr;

  Ext: ExtStr;

  TempFileOpen: integer;

  CheckIO: integer;

begin

  DumInt := IOResult;

  Assign(InFile, InFileStr);

  ModeChar := UpCase(ModeChar);

  {$I-}

  case ModeChar of

    'R': Reset(InFile);

    'W':

      begin

        Rewrite(InFile);

        if IOResult = 3 then

          if FileOpen('P', InFileStr, InFile) = 0 then

            Rewrite(InFile);

      end;

    'A': begin

           Append(InFile);

           CheckIO := IOResult;

           if CheckIO <> 0 then

             begin

               case CheckIO of

                 2: Rewrite(InFile);

                 3:

                   begin

                     DumInt := FileOpen('P', InFileStr, InFile);

                     Rewrite(InFile);

                   end;

                 else

                   Append(InFile);

               end; {case}

             end;

         end;

    'P': {* create Path *}

      begin

        FSplit(InFileStr, Dir, Name, Ext);

        Dir := copy(Dir, 1, length(Dir) - 1);

        DumBool := DirMake(Dir);

      end;

    else

      SayL(Beep+'Function FileOpen improperly used!');

  end; {case}

  {$I+}

  TempFileOpen := IOError;

  if TempFileOpen <> 0 then

    ErrSayL('** Error with "'+InFileStr+'".');

  FileOpen := TempFileOpen;

end;



Function  FileSearch(ModeChar: char; FileStr: string;

            var MatchStr: string): integer;

{***************************************************************************}

{* Modes: 'u'=case insensitive, 'l'=case sensitive

{* Return: -1 if file problem or bad mode, 0 if not found

{***************************************************************************}

var

  TempFileSearch: integer;

  Match: boolean;

  LineStr: string;

  alpha: integer;

  FS: text;

begin

  ModeChar := upcase(ModeChar);

  case ModeChar of

    'U': MatchStr := Data.UpCaseStr(MatchStr);

    'L':

      begin

      end;

    else

      begin

        SayL(Beep+'Bad mode character used with Function FileSearch!');

        FileSearch := -1;

        exit;

      end;

  end; {case}

  TempFileSearch := -1;

  Match := false;

  alpha := 0;

  if FileOpen('R', FileStr, FS) = 0 then

    begin

      TempFileSearch := 0;

      repeat

        inc(alpha);

        readln(FS, LineStr);

        if ModeChar = 'U' then

          begin

            if UpCaseStr(LineStr) = MatchStr then

              begin

                Match := true;

                MatchStr := LineStr;

              end;

          end

        else

          if LineStr = MatchStr then

            Match := true;

      until Match or EOF(FS);

      close(FS);

    end;

  if Match then

    TempFileSearch := alpha;

  FileSearch := TempFileSearch;

end;



Function  FileSizeAny(FileStr: string): longint;

{***************************************************************************}

{* The file can be text and can be closed.

{* Reports -1 if there is an error.

{***************************************************************************}

var

  S: SearchRec;

begin

  FindFirst(FileStr, AnyFile, S);

  if DosError <> 0 then

    FileSizeAny := -1

  else

    FileSizeAny := S.Size;

end;



Function GetDirFile(SearchStr: string): string;

{***************************************************************************}

var

  Count: integer;

  TempDirFile: string;

  FileOpt: integer;

  DirInfo: SearchRec;

  FileNameGood: boolean;

  Lead8: string;

begin

  TempDirFile := '';

  DirFiles(SearchStr, Count);

  writeln(Count+1,') Input a new file name.');

  AskPos('Which file (1 to '+StrInt(Count+1)+')',Count+1, FileOpt);

  if FileOpt = Count + 1 then

    begin

      repeat

        SplitFileName(SearchStr, DumStr, TempDirFile);

        GetFileName(Lead8, DumStr);

        TempDirFile := Lead8 + '.' + TempDirFile;

        writeln('Creating ',TempDirFile,'...');

        wait;

        FileNameGood := WildCardFormat(SearchStr,TempDirFile);

        if not(FileNameGood) then

          begin

            write(Beep);

            writeln('Must be of ',SearchStr,' format!');

            Wait;

            BackUpLines(5);

          end;

      until FileNameGood;

    end

  else

    begin

      FindFirst(SearchStr, AnyFile, DirInfo);

      for count := 1 to FileOpt do

        begin

          if DirInfo.Attr = 16 then

            count := count - 1

          else

            if count = FileOpt then

              TempDirFile := DirInfo.Name;

          FindNext(DirInfo);

        end;

    end;

  GetDirFile := TempDirFile;

end;



function GetDirFileOnly(SearchStr: string): string;

{***************************************************************************}

var

  Count: integer;

  TempDirFile: string;

  FileOpt: integer;

  DirInfo: SearchRec;

  FileNameGood: boolean;

begin

  TempDirFile := '';

  DirFiles(SearchStr, Count);

  if Count = 0 then

    begin

      Write(Beep);

      writeln;

      writeln('No ',SearchStr,' files found!');

      PoliteHalt;

    end;

  AskPos('Which file (1 to '+StrInt(Count)+')',Count, FileOpt);

  FindFirst(SearchStr, AnyFile, DirInfo);

  for count := 1 to FileOpt do

    begin

      if DirInfo.Attr = 16 then

        count := count - 1

      else

        if count = FileOpt then

          TempDirFile := DirInfo.Name;

      FindNext(DirInfo);

    end;

  GetDirFileOnly := TempDirFile;

end;



procedure GetFileName(var Lead8, Ext: string);

{***************************************************************************}

var

  InStr: string;

  NameGood: boolean;

begin

  repeat

    Ask('File name', InStr);

    SplitFileName(InStr, Lead8, Ext);

    if Lead8 = '' then

      begin

        NameGood := false;

        Write(Beep);

        BackUpLine;

      end

    else

      NameGood := true;

  until NameGood;

end;



Function  LineAppend(FileStr, InStr: string): boolean;

{***************************************************************************}

var

  AF: text;

  Temp: boolean;

begin

  Assign(AF, FileStr);

{$I-}

  Append(AF);

  writeln(AF, InStr);

  Close(AF);

{$I+}

  Temp := IOResult = 0;

  LineAppend := Temp;

end;



Function  LineRead(FileStr:string; Line: integer; var InStr:string): boolean;

{***************************************************************************}

var

  Count: integer;

  RF: text;

  Temp: boolean;

begin

  Assign(RF, FileStr);

{$I-}

  Reset(RF);

  Count := 0;

  if not(EOF(RF)) then

    repeat

      inc(Count);

      readln(RF, InStr);

    until EOF(RF) or (Count = Line);

  Close(RF);

{$I+}

  Temp := (IOResult = 0) and (Count = Line);

  LineRead := Temp;

end;



Function  LineWrite(FileStr: string; Line: integer; InStr: string): boolean;

{***************************************************************************}

var

  Index: integer;

  WF,

  TF: text;

  LineCount: integer;

  OldStr: string;

  InitIOResult: integer;

  Temp: boolean;

begin

  if FileExistsMake(FileStr) then

    InitIOResult := 0

  else

    InitIOResult := 99;

  Assign(WF, FileStr);

  Assign(TF, TempFile);

{$I-}

  Reset(WF);

  Rewrite(TF);

  LineCount := 1;

  InitIOResult := InitIOResult + IOResult;

  while (not(EOF(WF)) and (LineCount < Line)) and (InitIOResult = 0) do

    begin

      InitIOResult := InitIOResult + IOResult;

      readln(WF, OldStr);

      writeln(TF, OldStr);

      inc(LineCount);

    end;

  if (LineCount = Line) and (InitIOResult = 0) then

    begin

      writeln(TF, InStr);

      while not(EOF(WF)) and (InitIOResult = 0) do

        begin

          InitIOResult := InitIOResult + IOResult;

          readln(WF, OldStr);

          writeln(TF, OldStr);

        end;

    end

  else

   if InitIOResult = 0 then

    begin

      for Index := LineCount to Line - 1 do

        writeln(TF, '');

      writeln(TF, InStr);

    end;

  Close(WF);

  Close(TF);

  InitIOResult := IOResult + InitIOResult;

  if InitIOResult = 0 then

    begin

      Erase(WF);

      Rename(TF, FileStr);

    end;

{$I+}

  Temp := (IOResult = 0) and (InitIOResult = 0);

  LineWrite := Temp;

end;



Procedure SayFile(SayFileStr: string);

{***************************************************************************}

var

  TheSayFile: text;

  LineStr: string;

begin

  Assign(TheSayFile, SayFileStr);

  {$I-}

  Reset(TheSayFile);

  {$I+}

  if IOGood then

    begin

      clr;

      repeat

        readln(TheSayFile, LineStr);

        Say(LineStr);

        if WhereY >= 22 then

          begin

            wait;

            clr;

          end;

      until EOF(TheSayFile);

    end;

  Close(TheSayFile);

  Wait;

end;



procedure SplitFileName(InFile: string; var Lead8, Extension: string);

{***************************************************************************}

{*  If a non-filename is inputted, Lead8 will contain the first 8 and

{*  Extension will contain the next 3.  The rest will be discarded.

{***************************************************************************}

var

  Dot: integer;

  ExtLen: integer;

begin

  Dot := Pos('.',InFile);

  if Dot > 9 then

    Lead8 := copy(InFile, 1, 8)

  else

    if Dot = 1 then

      Lead8 := ''

    else

      if Dot = 0 then

        Lead8 := copy(InFile, 1, 8)

      else

        Lead8 := copy(InFile, 1, Dot - 1);

  if Dot > 0 then

    begin

      ExtLen := length(InFile) - length(Lead8) - 1;

      if ExtLen > 3 then

        ExtLen := 3;

      Extension := copy(InFile, Dot+1, ExtLen);

    end

  else

    Extension := '';

end;





{***************************************************************************}

{***************************************************************************}

{***************************************************************************}

begin

end.