Beijing Paradise BBS Backup/PARADISE.ISO/software/BBSDOORW/MFM_119C.ZIP/SLCTDIR.PAS

Pascal/Delphi Source File | 1993-06-03 | 15.9 KB | 470 lines

Unit SlctDir;
{========================================================================}
Interface
  Uses
    Dos;
  Function SelectDir(FileAreaPath : PathStr) : PathStr;
{========================================================================}
Implementation
  Uses
    Crt, MfmStr, Screen;
  Type
    ListPtr = ^ListRecord;
    ListRecord = Record
      Next, Prev : ListPtr;
      Attr : Byte;
      Name : String[12];
    End;
  Var
    DirInfo : SearchRec;
    FirstEntry, CurrentEntry, TempEntry : ListPtr;
    TempRecord : ListRecord;
    NoOfEntries, CurrentEntryNo : Word;
    NoEntryToShow : Byte;
    CurrentDrive : Byte;
    ForChar : Char;
    Msr : Registers;
    DriveList, TempString : String;
{========================================================================}
Procedure BuildDirList(FileSpec : PathStr);
  Begin
    FirstEntry := NIL; NoOfEntries := 0;
    FindFirst(FileSpec, AnyFile, DirInfo);
    While DosError = 0 Do
    Begin
      If DirInfo.Name = '.' Then FindNext(DirInfo);
      If DirInfo.Attr = Directory Then
      Begin
        New(CurrentEntry); Inc(NoOfEntries);
        If FirstEntry = NIL Then
        Begin
          FirstEntry := CurrentEntry;
          CurrentEntry^.Prev := NIL;
        End
        Else
        Begin
          CurrentEntry^.Prev := TempEntry;
          TempEntry^.Next := CurrentEntry;
        End;
        CurrentEntry^.Next := NIL;
        CurrentEntry^.Attr := DirInfo.Attr;
        CurrentEntry^.Name := DirInfo.Name;
        TempEntry := CurrentEntry;
      End;
      FindNext(DirInfo);
    End;
  End;
{========================================================================}
Procedure SortDirList;
  Var
    Exchange : Boolean;
  Begin
    If FirstEntry <> NIL Then
    Begin
      New(TempEntry);
      Repeat
        Exchange := False;
        CurrentEntry := FirstEntry;
        While CurrentEntry^.Next <> NIL Do
        Begin
          If CurrentEntry^.Name > CurrentEntry^.Next^.Name Then
          Begin
            TempEntry^.Attr := CurrentEntry^.Attr;
            CurrentEntry^.Attr := CurrentEntry^.Next^.Attr;
            CurrentEntry^.Next^.Attr := TempEntry^.Attr;
            TempEntry^.Name := CurrentEntry^.Name;
            CurrentEntry^.Name := CurrentEntry^.Next^.Name;
            CurrentEntry^.Next^.Name := TempEntry^.Name;
            Exchange := True;
          End;
          CurrentEntry := CurrentEntry^.Next;
        End;
      Until (Not Exchange);
      Dispose(TempEntry);
    End;
  End;
{========================================================================}
Procedure DisplayDirList;
  Begin
    If FirstEntry <> NIL Then
    Begin
      CurrentEntry := FirstEntry;
      WriteLn(' File List ');
      WriteLn('-----------');
      WriteLn(CurrentEntry^.Name);
      While CurrentEntry^.Next <> NIL Do
      Begin
        CurrentEntry := CurrentEntry^.Next;
        WriteLn(CurrentEntry^.Name);
      End;
    End;
  End;
{========================================================================}
Procedure RemoveDirList;
  Begin
    If FirstEntry <> NIL Then
    Begin
      CurrentEntry := FirstEntry;
      While CurrentEntry^.Next <> NIL Do
      Begin
        TempEntry := CurrentEntry;
        CurrentEntry := CurrentEntry^.Next;
        Dispose(TempEntry);
      End;
      Dispose(CurrentEntry);
    End;
  End;
{========================================================================}
Function DisplayEntryNo(EntryNo : Byte) : String;
  Var
    EntryNoCtr : Byte;
  Begin
    If FirstEntry <> NIL Then
    Begin
      TempEntry := FirstEntry; EntryNoCtr := 1;
      While (EntryNoCtr < EntryNo) And (EntryNoCtr < NoOfEntries) Do
      Begin
        TempEntry := TempEntry^.Next;
        Inc(EntryNoCtr);
      End;
      If EntryNoCtr = EntryNo Then
      Begin
        DisplayEntryNo := TempEntry^.Name+Copy('            ',1,12-Length(TempEntry^.Name));
        TempRecord.Attr := TempEntry^.Attr;
        TempRecord.Name := TempEntry^.Name;
      End
      Else
      Begin
        DisplayEntryNo := '            ';
        TempRecord.Attr := 0;
        TempRecord.Name := '';
      End;
    End
    Else
    Begin
      DisplayEntryNo := 'None';
    End;
  End;
{========================================================================}
Procedure DisplayEntryList(StartFrom : Word; Col, Row : Byte);
  Var
    Lsi : Word;
  Begin
    If FirstEntry <> NIL Then
    Begin
      AnsiGotoXYNew(Col,Row);
      If StartFrom > 1 Then WriteLn(' ^ ') Else WriteLn('═══');
      Inc(Row);
      For Lsi := StartFrom To StartFrom+(NoEntryToShow-1) Do
      Begin
        AnsiGotoXYNew(Col,Row);
        WriteLn(DisplayEntryNo(Lsi));
        Inc(Row);
      End;
      AnsiGotoXYNew(Col,Row);
      If NoOfEntries > StartFrom+(NoEntryToShow-1) Then WriteLn(' v ') Else WriteLn('═══');
      Inc(Row);
    End;
  End;
{========================================================================}
Procedure DoubleBox(Col, Row, Height, Width : Byte);
  Var
    Dbb : Byte;
  Begin
    AnsiGotoXYNew(Col,Row); Write('╔');
    For Dbb := 1 To Width-1 Do Write('═');
    Write('╗');
    For Dbb := 1 To Height Do
    Begin
      AnsiGotoXYNew(Col,Row+Dbb); Write('║');
      AnsiGotoXYNew(Col+Width,Row+Dbb); Write('║');
    End;
    AnsiGotoXYNew(Col,Row+Dbb); Write('╚');
    For Dbb := 1 To Width-1 Do Write('═');
    Write('╝');
  End;
{========================================================================}
Function SelectDir(FileAreaPath : PathStr) : PathStr;
  Const
    NoOfFiles = 15;
    Col = 2;
    Row = 2;
  Var
    SelPos, Sfb : Byte;
    Sfc : Char;
    TopChanged : Boolean;
    TopEntry : Word;
    D: DirStr;
    N: NameStr;
    E: ExtStr;
  Begin
    AnsiClearScreen;
    FSplit(FExpand(FileAreaPath),D,N,E);
    BuildDirList(FileAreaPath);
    SortDirList;
    If FirstEntry <> NIL Then
    Begin
      SelPos := 1;
      TopEntry := 1;
      TopChanged := True;
      NoEntryToShow := NoOfFiles;
      DoubleBox(Col,Row,NoEntryToShow+1,15);
      AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
      AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
      Repeat
        If TopChanged Then
        Begin
          DisplayEntryList(TopEntry,Col+2,Row);
          AnsiGotoXYNew(41,15); Write('D - Change Drive');
          AnsiGotoXYNew(41,16); Write('Q - Quit to Area Select');
          AnsiGotoXYNew(41,17); Write('S - Select Directory');
          TopChanged := False;
        End;
        AnsiGotoXYNew(50,1); AnsiClearToEol;
        If Pos('..',DisplayEntryNo(SelPos)) > 0 Then
        Begin
          Write(D);
        End
        Else
        Begin
          Write(AllTrim(D+DisplayEntryNo(SelPos))+'\');
        End;
        Repeat
          Sfb := GetInput;
          Sfc := Upcase(Chr(Sfb));
          If Sfb = 0 Then
          Begin
            Sfb := GetInput;
            Case Sfb Of
              71 : Sfc := '7';
              72 : Sfc := '8';
              73 : Sfc := '9';
              75 : Sfc := '4';
              77 : Sfc := '6';
              79 : Sfc := '1';
              80 : Sfc := '2';
              81 : Sfc := '3';
            End;
          End;
        Until Sfc In [#13,#27,'1','2','3','7','8','9','D','Q','S'];
        Case Sfc Of
          '1' : Begin
                  If SelPos < NoOfEntries Then
                  Begin
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                    SelPos := NoOfEntries;
                    If NoOfEntries > NoOfFiles Then
                    Begin
                      TopEntry := (NoOfEntries-NoOfFiles)+1;
                      TopChanged := True;
                    End;
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                  End;
                End;
          '2' : Begin
                  If SelPos < NoOfEntries Then
                  Begin
                    If (SelPos-TopEntry)+2 > NoOfFiles Then
                    Begin
                      Inc(TopEntry);
                      TopChanged := True;
                      Inc(SelPos);
                    End
                    Else
                    Begin
                      AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                      AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                      Inc(SelPos);
                      AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                      AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                    End;
                  End;
                End;
          '3' : Begin
                  If SelPos < NoOfEntries Then
                  Begin
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                    If NoOfEntries < NoOfFiles Then
                    Begin
                      SelPos := NoOfEntries;
                    End
                    Else
                    Begin
                      If SelPos+NoOfFiles < NoOfEntries Then
                      Begin
                        SelPos := SelPos+NoOfFiles;
                        TopEntry := TopEntry+NoOfFiles;
                        TopChanged := True;
                      End
                      Else
                      Begin
                        SelPos := NoOfEntries;
                        TopEntry := (NoOfEntries-NoOfFiles)+1;
                        TopChanged := True;
                      End;
                    End;
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                  End;
                End;
          '7' : Begin
                  If SelPos > 1 Then
                  Begin
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                    SelPos := 1;
                    AnsiGotoXYNew(Col+1,Row+1); Write('>');
                    AnsiGotoXYNew(Col+14,Row+1); Write('<');
                  End;
                  If TopEntry > 1 Then
                  Begin
                    TopEntry := 1;
                    TopChanged := True;
                  End;
                End;
          '8' : Begin
                  If SelPos > 1 Then
                  Begin
                    If SelPos = TopEntry Then
                    Begin
                      Dec(TopEntry);
                      TopChanged := True;
                      Dec(SelPos);
                    End
                    Else
                    Begin
                      AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                      AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                      Dec(SelPos);
                      AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                      AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                    End;
                  End;
                End;
          '9' : Begin
                  If SelPos > 1 Then
                  Begin
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write(' ');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write(' ');
                    If NoOfEntries < NoOfFiles Then
                    Begin
                      SelPos := 1;
                    End
                    Else
                    Begin
                      If SelPos-NoOfFiles > 1 Then
                      Begin
                        SelPos := SelPos-NoOfFiles;
                        If TopEntry > NoOfFiles Then
                        Begin
                          TopEntry := TopEntry-NoOfFiles;
                        End
                        Else
                        Begin
                          TopEntry := SelPos;
                        End;
                        TopChanged := True;
                      End
                      Else
                      Begin
                        SelPos := 1;
                        TopEntry := 1;
                        TopChanged := True;
                      End;
                    End;
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                  End;
                End;
          'D' : Begin
                  DriveList := '';
                  Msr.Ah := $19;
                  MsDos(Msr);
                  CurrentDrive := Msr.Al;
                  For ForChar := 'A' To 'Z' Do
                  Begin
                    Msr.Ah := $0E;
                    Msr.Dl := Ord(ForChar) - Ord('A');
                    MsDos(Msr);
                    Msr.Ah := $19;
                    MsDos(Msr);
                    If Msr.Al = Msr.Dl Then DriveList := DriveList+(Char(Msr.Al+Ord('A')))+': ';
                  End;
                  Msr.Ah := $0E;
                  Msr.Dl := CurrentDrive;
                  MsDos(Msr);
                  AnsiGotoXYNew(1,25);
                  Write(DriveList);
                  AnsiGotoXYNew(41,23);
                  Write('Select drive: ');
                  Repeat
                    Sfc := Upcase(ReadKey);
                  Until (Pos(Sfc,DriveList) > 0) Or (Sfc = #27);
                  If Sfc <> #27 Then
                  Begin
                    GetDir(Ord(Sfc)-(Ord('A')-1),TempString);
                    AnsiGotoXYNew(41,21); ClrEol;
                    Write(TempString);
                    If Copy(TempString,Length(TempString),1) <> '\' Then TempString := TempString+'\';
                    FSplit(FExpand(TempString+N+E),D,N,E);
                    FileAreaPath := D+N+E;
                    RemoveDirList;
                    BuildDirList(FileAreaPath);
                    SortDirList;
                    SelPos := 1;
                    TopEntry := 1;
                    TopChanged := True;
                    NoEntryToShow := NoOfFiles;
                    AnsiClearScreen;
                    DoubleBox(Col,Row,NoEntryToShow+1,15);
                    AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
                    AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
                    Sfc := ' ';
                  End;
                End;
        End;
        If (Sfc = #13) And (TempRecord.Attr = Directory) Then
        Begin
          FSplit(FExpand(D+TempRecord.Name+'\'+N+E),D,N,E);
          FileAreaPath := D+N+E;
          RemoveDirList;
          BuildDirList(FileAreaPath);
          SortDirList;
          SelPos := 1;
          TopEntry := 1;
          TopChanged := True;
          NoEntryToShow := NoOfFiles;
          AnsiClearScreen;
          DoubleBox(Col,Row,NoEntryToShow+1,15);
          AnsiGotoXYNew(Col+1,Row+(SelPos-TopEntry)+1); Write('>');
          AnsiGotoXYNew(Col+14,Row+(SelPos-TopEntry)+1); Write('<');
          Sfc := ' ';
        End;
      Until Sfc In [#27,'S','Q'];
      If Sfc In [#27,'Q'] Then
      Begin
        SelectDir := '';
      End
      Else
      Begin
        If Pos('..',DisplayEntryNo(SelPos)) > 0 Then
        Begin
          SelectDir := D;
        End
        Else
        Begin
          SelectDir := AllTrim(D+DisplayEntryNo(SelPos))+'\';
        End;
      End;
      CurrentEntryNo := SelPos;
    End;
    RemoveDirList;
  End;
{========================================================================}
Begin
End.
{========================================================================}