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

Pascal/Delphi Source File | 1993-06-03 | 17.1 KB | 571 lines

Unit MaxAreas;
{========================================================================}
Interface
  Uses
    Dos;
  Function SelectArea(AreaPath : PathStr; Var DnLdPath, FilesBbsPath : PathStr; Var OldArea : Word) : Byte;
{========================================================================}
Implementation
  Uses
    Crt, General, Help, MfmDefs, Screen, Setup, SlctDir, Strings;
  Const
    MaxClass = 12;
    MaxOvr = 16;
    TopLine = 1;
    BottomLine = 23;
  Type
    ArrayInPtr = ^ArrayInType;
    ArrayInType = Array[1..255] Of Char;
    Override = Record
      Priv : Integer;
      Lock1, lock2 : Word;
      Ch : Char;
      Fill : Byte;
    End;
    AreaRecordType = Record
      Id : Array[0..3] Of Char;
      StructLen : Word;
      AreaNo : Array[0..1] Of Char;
      Name : Array[0..39] Of Char;
      AreaType : Word;
      MsgPath : Array[0..79] Of Char;
      MsgName : Array[0..39] Of Char;
      MsgInfo, MsgBar : Array[0..79] Of Char;
      Origin : Array[0..61] Of Char;
      MsgPriv : Integer;
      MsgLock, Fill1 : Byte;
      OriginAka : Word;
      FilePath, UpPath, FileBar, FilesBbs, FileInfo : Array[0..79] Of Char;
      FilePriv : Integer;
      FileLock, Fill2 : Byte;
      MsgMenuName, FileMenuName : Array[0..12] Of Char;
      Attrib : Array[1..MaxClass] Of Word;
      Movr : Array[1..MaxOvr] Of Override;
      Fovr : Array[1..MaxOvr] Of Override;
      MsgLock1, MsgLock2, FileLock1, FileLock2 : Word;
      KillByAge, KillByNum : Word;
    End;
  Var
    StructLen : Word;
    TotalAreas, FirstArea, LastArea, AreaNum, TopArea, BottomArea : Word;
    RecordBuffer : Pointer;
    AreaDat : File;
    MaxAreaRecord : ^AreaRecordType;
    Row, BottomRow : Byte;
{========================================================================}
Function OpenMaxArea(AreaPath : PathStr) : Boolean;
  Begin
    Assign(AreaDat,AreaPath);
    FileMode := 64; {ReadOnly & DenyNone}
    {$I-} Reset(AreaDat,1); {$I+}
    If DosError = 0 Then
    Begin
      OpenMaxArea := True;
      Seek(AreaDat,4);
      BlockRead(AreaDat,StructLen,SizeOf(StructLen));
      TotalAreas := FileSize(AreaDat) Div StructLen;
      GetMem(RecordBuffer,StructLen);
    End
    Else
    Begin
      OpenMaxArea := False;
    End;
  End;
{========================================================================}
Function GetMaxArea(AreaNo : LongInt) : Byte;
  Begin
    If (StructLen*AreaNo) > FileSize(AreaDat) Then
    Begin
      GetMaxArea := 254;
    End
    Else
    Begin
      Seek(AreaDat,StructLen*(AreaNo-1));
      BlockRead(AreaDat,RecordBuffer^,StructLen);
      GetMaxArea := 0;
    End;
  End;
{========================================================================}
Procedure CloseMaxArea;
  Begin
    Close(AreaDat);
    FreeMem(RecordBuffer,StructLen);
  End;
{========================================================================}
Function Priv(PrivIn : Integer) : String;
  Begin
    Case PrivIn Of
     -2 : Priv := 'Twit';
      0 : Priv := 'Disgrace';
      1 : Priv := 'Limited';
      2 : Priv := 'Normal';
      3 : Priv := 'Worthy';
      4 : Priv := 'Privil';
      5 : Priv := 'Favored';
      6 : Priv := 'Extra';
      7 : Priv := 'Clerk';
      8 : Priv := 'AsstSysop';
     10 : Priv := 'Sysop';
     11 : Priv := 'Hidden';
    Else
      Priv := 'Hidden';
    End;
  End;
{========================================================================}
Function Keys(Keys1, Keys2 : Word) : String;
  Var
    Ks : String;
  Begin
    Ks := '';
    If Keys1+Keys2 > 0 Then
    Begin
      Ks := '/';
      If (Keys1 And 1) = 1 Then Ks := Ks+'1';
      If (Keys1 And 2) = 2 Then Ks := Ks+'2';
      If (Keys1 And 4) = 4 Then Ks := Ks+'3';
      If (Keys1 And 8) = 8 Then Ks := Ks+'4';
      If (Keys1 And 16) = 16 Then Ks := Ks+'5';
      If (Keys1 And 32) = 32 Then Ks := Ks+'6';
      If (Keys1 And 64) = 64 Then Ks := Ks+'7';
      If (Keys1 And 128) = 128 Then Ks := Ks+'8';
      If (Keys1 And 256) = 256 Then Ks := Ks+'A';
      If (Keys1 And 512) = 512 Then Ks := Ks+'B';
      If (Keys1 And 1024) = 1024 Then Ks := Ks+'C';
      If (Keys1 And 2048) = 2048 Then Ks := Ks+'D';
      If (Keys1 And 4096) = 4096 Then Ks := Ks+'E';
      If (Keys1 And 8192) = 8192 Then Ks := Ks+'F';
      If (Keys1 And 16384) = 16384 Then Ks := Ks+'G';
      If (Keys1 And 32768) = 32768 Then Ks := Ks+'H';
      If (Keys2 And 1) = 1 Then Ks := Ks+'I';
      If (Keys2 And 2) = 2 Then Ks := Ks+'J';
      If (Keys2 And 4) = 4 Then Ks := Ks+'K';
      If (Keys2 And 8) = 8 Then Ks := Ks+'L';
      If (Keys2 And 16) = 16 Then Ks := Ks+'M';
      If (Keys2 And 32) = 32 Then Ks := Ks+'N';
      If (Keys2 And 64) = 64 Then Ks := Ks+'O';
      If (Keys2 And 128) = 128 Then Ks := Ks+'P';
      If (Keys2 And 256) = 256 Then Ks := Ks+'Q';
      If (Keys2 And 512) = 512 Then Ks := Ks+'R';
      If (Keys2 And 1024) = 1024 Then Ks := Ks+'S';
      If (Keys2 And 2048) = 2048 Then Ks := Ks+'T';
      If (Keys2 And 4096) = 4096 Then Ks := Ks+'U';
      If (Keys2 And 8192) = 8192 Then Ks := Ks+'V';
      If (Keys2 And 16384) = 16384 Then Ks := Ks+'W';
      If (Keys2 And 32768) = 32768 Then Ks := Ks+'X';
    End;
    Keys := Ks;
  End;
{========================================================================}
Procedure BlankCurrentLocation(Row : Byte);
  Begin
    NewTextColor(White);
    AnsiGotoXY(Row,1); Write(' ');
    AnsiGotoXY(Row,47); Write(' ');
    AnsiGotoXY(24,80);
  End;
{========================================================================}
Procedure DisplayCurrentLocation(Row : Byte);
  Begin
    NewTextColor(White+Blink);
    AnsiGotoXY(Row,1); Write('>');
    AnsiGotoXY(Row,47); Write('>');
    NewTextColor(White);
    AnsiGotoXY(25,1); AnsiClearToEOL;
    Write(Priv(MaxAreaRecord^.FilePriv)+Keys(MaxAreaRecord^.FileLock1,MaxAreaRecord^.FileLock2));
    AnsiGotoXY(25,45);
    If StrLen(MaxAreaRecord^.FilesBbs) = 0 Then
    Begin
      Write(MaxAreaRecord^.FilePath);
      Write('Files.Bbs');
    End
    Else
    Begin
      Write(MaxAreaRecord^.FilesBbs);
    End;
    AnsiGotoXY(24,80);
  End;
{========================================================================}
Procedure DisplayRecord(Row : Byte);
  Var
    AreaLine : Array[0..79] Of Char;
  Begin
    AnsiGotoXY(Row,1); AnsiClearToEOL;
    AnsiGotoXY(Row,2);
    NewTextColor(White);
    StrLCopy(AreaLine,MaxAreaRecord^.Name,4);
    Write(AreaLine);
    AnsiGotoXY(Row,7);
    NewTextColor(Yellow);
    StrLCopy(AreaLine,MaxAreaRecord^.FileInfo,40);
    Write(AreaLine);
    AnsiGotoXY(Row,48);
    NewTextColor(LightGreen);
    StrLCopy(AreaLine,MaxAreaRecord^.FilePath,30);
    Write(AreaLine);
  End;
{========================================================================}
Procedure DisplayScreen;
  Var
    Row : Byte;
    AreaNum : Integer;
  Begin
    SetupScreen;
    Row := TopLine-1;
    AreaNum := TopArea;
    While (AreaNum <= LastArea) And (Row < BottomLine) Do
    Begin
      GetMaxArea(AreaNum);
      While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum < LastArea) Do
      Begin
        Inc(AreaNum);
        GetMaxArea(AreaNum);
      End;
      BottomArea := AreaNum;
      If StrLen(MaxAreaRecord^.FilePath) > 0 Then
      Begin
        Inc(Row); Inc(AreaNum);
        DisplayRecord(Row);
      End;
      BottomRow := Row;
    End;
  End;
{========================================================================}
Procedure LineUp;
  Begin
    If AreaNum > FirstArea Then
    Begin
      If Row > TopLine Then
      Begin
        BlankCurrentLocation(Row); Dec(Row); Dec(AreaNum);
      End
      Else
      Begin
        Dec(TopArea); DisplayScreen; Dec(AreaNum);
      End;
      GetMaxArea(AreaNum);
      While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum > FirstArea) Do
      Begin
        Dec(AreaNum); GetMaxArea(AreaNum);
      End;
      DisplayCurrentLocation(Row);
    End;
  End;
{========================================================================}
Procedure LineDown;
  Begin
    If AreaNum < LastArea Then
    Begin
      If Row < BottomLine Then
      Begin
        BlankCurrentLocation(Row); Inc(Row); Inc(AreaNum);
      End
      Else
      Begin
        Inc(TopArea); DisplayScreen; Inc(AreaNum);
      End;
      GetMaxArea(AreaNum);
      While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum < LastArea) Do
      Begin
        Inc(AreaNum); GetMaxArea(AreaNum);
      End;
      DisplayCurrentLocation(Row);
    End;
  End;
{========================================================================}
Procedure PageUp;
  Var
    Counter : Byte;
  Begin
    If AreaNum <> FirstArea Then
    Begin
      If TotalAreas <= BottomLine Then
      Begin
        AreaNum := FirstArea;
        BlankCurrentLocation(Row);
        Row := TopLine;
        GetMaxArea(AreaNum);
        DisplayCurrentLocation(Row);
      End
      Else
      Begin
        If Row = TopLine Then
        Begin
          Counter := BottomLine;
          While (Counter > 1) And (AreaNum > FirstArea) Do
          Begin
            Dec(AreaNum); Dec(Counter);
            GetMaxArea(AreaNum);
            While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum > FirstArea) Do
            Begin
              Dec(AreaNum); GetMaxArea(AreaNum);
            End;
          End;
          TopArea := AreaNum;
          DisplayScreen;
          GetMaxArea(AreaNum);
          DisplayCurrentLocation(Row);
        End
        Else
        Begin
          AreaNum := TopArea;
          BlankCurrentLocation(Row);
          Row := TopLine;
          GetMaxArea(AreaNum);
          DisplayCurrentLocation(Row);
        End;
      End;
    End;
  End;
{========================================================================}
Procedure PageDown;
  Var
    Counter : Byte;
  Begin
    If Not ((Row = BottomLine) And (AreaNum = LastArea)) Then
    Begin
      If TotalAreas <= BottomLine Then
      Begin
        AreaNum := LastArea;
        BlankCurrentLocation(Row);
        Row := TotalAreas;
        GetMaxArea(AreaNum);
        DisplayCurrentLocation(Row);
      End
      Else
      Begin
        If AreaNum = LastArea Then
        Begin
          For Counter := 1 To BottomLine-1 Do
          Begin
            Dec(AreaNum);
            GetMaxArea(AreaNum);
            While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum > FirstArea) Do
            Begin
              Dec(AreaNum); GetMaxArea(AreaNum);
            End;
          End;
          TopArea := AreaNum;
          DisplayScreen;
          Row := BottomLine;
          AreaNum := LastArea;
          GetMaxArea(AreaNum);
          DisplayCurrentLocation(Row);
        End
        Else
        Begin
          If Row = BottomLine Then
          Begin
            TopArea := BottomArea;
            DisplayScreen;
            AreaNum := BottomArea;
            GetMaxArea(AreaNum);
            Row := BottomRow;
            DisplayCurrentLocation(Row);
          End
          Else
          Begin
            AreaNum := BottomArea;
            BlankCurrentLocation(Row);
            Row := BottomLine;
            GetMaxArea(AreaNum);
            DisplayCurrentLocation(Row);
          End;
        End;
      End;
    End;
  End;
{========================================================================}
Procedure TopOfList;
  Begin
    If TopArea <> FirstArea Then
    Begin
      TopArea := FirstArea;
      DisplayScreen;
    End
    Else
    Begin
      BlankCurrentLocation(Row);
    End;
    AreaNum := FirstArea;
    GetMaxArea(AreaNum);
    Row := TopLine;
    DisplayCurrentLocation(Row);
  End;
{========================================================================}
Procedure BottomOfList;
  Var
    Counter : Byte;
  Begin
    If Not ((Row = BottomLine) And (AreaNum = LastArea)) Then
    Begin
      AreaNum := LastArea;
      If TotalAreas <= BottomLine Then
      Begin
        BlankCurrentLocation(Row);
        Row := TotalAreas;
        GetMaxArea(AreaNum);
        DisplayCurrentLocation(Row);
      End
      Else
      Begin
        For Counter := 1 To BottomLine-1 Do
        Begin
          Dec(AreaNum);
          GetMaxArea(AreaNum);
          While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum > FirstArea) Do
          Begin
            Dec(AreaNum); GetMaxArea(AreaNum);
          End;
        End;
        TopArea := AreaNum;
        DisplayScreen;
        Row := BottomLine;
        AreaNum := LastArea;
        GetMaxArea(AreaNum);
        DisplayCurrentLocation(Row);
      End;
    End;
  End;
{========================================================================}
Function SelectArea(AreaPath : PathStr; Var DnLdPath, FilesBbsPath : PathStr; Var OldArea : Word) : Byte;
  Var
    Sab, Counter : Byte;
    Sac : Char;
    TempAreaPath : PathStr;
  Begin
    SelectArea := 0;
    If FileExist(AreaPath) Then
    Begin
      If OpenMaxArea(AreaPath) Then
      Begin
        TotalAreas := 0; FirstArea := 0; LastArea := 0; AreaNum := 1;
        While GetMaxArea(AreaNum) = 0 Do
        Begin
          MaxAreaRecord := RecordBuffer;
          If StrLen(MaxAreaRecord^.FilePath) > 0 Then
          Begin
            Inc(TotalAreas);
            LastArea := AreaNum;
          End;
          Inc(AreaNum);
        End;
        If TotalAreas > 0 Then
        Begin
          Repeat
            GetMaxArea(AreaNum);
            MaxAreaRecord := RecordBuffer;
            If StrLen(MaxAreaRecord^.FilePath) > 0 Then FirstArea := AreaNum;
            Dec(AreaNum);
          Until AreaNum = 0;
          If OldArea = $FFFF Then
          Begin
            OldArea := FirstArea;
            TopArea := FirstArea;
          End;
          If TopArea = OldArea Then
          Begin
            DisplayScreen;
            Row := TopLine;
          End
          Else
          Begin
            AreaNum := OldArea;
            Counter := BottomLine;
            While (Counter > 1) And (AreaNum > FirstArea) Do
            Begin
              Dec(AreaNum); Dec(Counter);
              GetMaxArea(AreaNum);
              While (StrLen(MaxAreaRecord^.FilePath) = 0) And (AreaNum > FirstArea) Do
              Begin
                Dec(AreaNum); GetMaxArea(AreaNum);
              End;
            End;
            TopArea := AreaNum;
            DisplayScreen;
            Row := (BottomLine-Counter)+1;
          End;
          AreaNum := OldArea;
          GetMaxArea(AreaNum);
          DisplayCurrentLocation(Row);
          Repeat
            GetMaxArea(AreaNum);
            Sab := GetInput;
            Sac := Upcase(Chr(Sab));
            If Sab = 0 Then
            Begin
              Sab := GetInput;
              Case Sab Of
                71 : Sac := '7';
                72 : Sac := '8';
                73 : Sac := '9';
                75 : Sac := '4';
                77 : Sac := '6';
                79 : Sac := '1';
                80 : Sac := '2';
                81 : Sac := '3';
              End;
            End;
            Case Sac Of
              '8' : LineUp;
              '2' : LineDown;
              '9' : PageUp;
              '3' : PageDown;
              '7' : TopOfList;
              '1' : BottomOfList;
              ^I  : Begin
                      If TabOk Then
                      Begin
                        TempAreaPath := SelectDir(StrPas(MaxAreaRecord^.FilePath)+'*.*');
                        If Length(TempAreaPath) = 0 Then
                        Begin
                          Sac := ' ';
                          DisplayScreen;
                          GetMaxArea(AreaNum);
                          DisplayCurrentLocation(Row);
                        End
                        Else
                        Begin
                          DnLdPath := TempAreaPath;
                          FilesBbsPath := DnLdPath+'Files.Bbs';
                        End;
                      End
                      Else
                      Begin
                        Sac := ' ';
                      End;
                    End;
              '?' : Begin
                      AreaHelp;
                      DisplayScreen;
                      GetMaxArea(AreaNum);
                      DisplayCurrentLocation(Row);
                    End;
            End;
          Until Sac In [^I,^M,^Q,^[];
          If Sac = ^M Then
          Begin
            DnLdPath := StrPas(MaxAreaRecord^.FilePath);
            FilesBbsPath := StrPas(MaxAreaRecord^.FilesBbs);
            If Length(FilesBbsPath) = 0 Then FilesBbsPath := DnLdPath+'Files.Bbs';
          End;
          If Sac = ^Q Then SelectArea := 253;
          If Sac = ^[ Then SelectArea := 252;
        End;
        CloseMaxArea;
      End
      Else
      Begin
        SelectArea := 254;
      End;
    End
    Else
    Begin
      SelectArea := 255;
    End;
    If Sac = ^M Then OldArea := AreaNum;
  End;
{========================================================================}
Begin
End.
{========================================================================}