home *** CD-ROM | disk | FTP | other *** search
/ The Devil's Doorknob BBS Capture (1996-2003) / devilsdoorknobbbscapture1996-2003.iso / Dloads / OTHERUTI / TPASCAL3.ZIP / TVISION.ZIP / STDDLG.PAS < prev    next >
Pascal/Delphi Source File  |  1991-06-11  |  37KB  |  1,444 lines
  1.  
  2. {*******************************************************}
  3. {                                                       }
  4. {       Turbo Pascal Version 6.0                        }
  5. {       Turbo Vision Unit                               }
  6. {                                                       }
  7. {       Copyright (c) 1990 Borland International        }
  8. {                                                       }
  9. {*******************************************************}
  10.  
  11. unit StdDlg;
  12.  
  13. {$F+,O+,V-,X+}
  14.  
  15. interface
  16.  
  17. uses Objects, Drivers, Views, Dialogs, Dos;
  18.  
  19. const
  20.  
  21. { Commands }
  22.  
  23.   cmFileOpen    = 800;   { Returned from TFileDialog when Open pressed }
  24.   cmFileReplace = 801;   { Returned from TFileDialog when Replace pressed }
  25.   cmFileClear   = 802;   { Returned from TFileDialog when Clear pressed }
  26.   cmFileInit    = 803;   { Used by TFileDialog internally }
  27.   cmChangeDir   = 804;   { Used by TChDirDialog internally }
  28.   cmRevert      = 805;   { Used by TChDirDialog internally }
  29.  
  30. { Messages }
  31.  
  32.   cmFileFocused = 806;    { A new file was focused in the TFileList }
  33.   cmFileDoubleClicked     { A file was selected in the TFileList }
  34.                 = 807;
  35.  
  36. type
  37.  
  38.   { TSearchRec }
  39.  
  40.   {  Record used to store directory information by TFileDialog }
  41.  
  42.   TSearchRec = record
  43.     Attr: Byte;
  44.     Time: Longint;
  45.     Size: Longint;
  46.     Name: string[12];
  47.   end;
  48.  
  49. type
  50.  
  51.   { TFileInputLine is a special input line that is used by      }
  52.   { TFileDialog that will update its contents in response to a  }
  53.   { cmFileFocused command from a TFileList.                     }
  54.  
  55.   PFileInputLine = ^TFileInputLine;
  56.   TFileInputLine = object(TInputLine)
  57.     constructor Init(var Bounds: TRect; AMaxLen: Integer);
  58.     procedure HandleEvent(var Event: TEvent); virtual;
  59.   end;
  60.  
  61.   { TFileCollection is a collection of TSearchRec's.            }
  62.  
  63.   PFileCollection = ^TFileCollection;
  64.   TFileCollection = object(TSortedCollection)
  65.     function Compare(Key1, Key2: Pointer): Integer; virtual;
  66.     procedure FreeItem(Item: Pointer); virtual;
  67.     function GetItem(var S: TStream): Pointer; virtual;
  68.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  69.   end;
  70.  
  71.   { TSortedListBox is a TListBox that assumes it has a          }
  72.   { TStoredCollection instead of just a TCollection.  It will   }
  73.   { perform an incremental search on the contents.              }
  74.  
  75.   PSortedListBox = ^TSortedListBox;
  76.   TSortedListBox = object(TListBox)
  77.     SearchPos: Word;
  78.     ShiftState: Byte;
  79.     constructor Init(var Bounds: TRect; ANumCols: Word;
  80.       AScrollBar: PScrollBar);
  81.     procedure HandleEvent(var Event: TEvent); virtual;
  82.     function GetKey(var S: String): Pointer; virtual;
  83.     procedure NewList(AList: PCollection); virtual;
  84.   end;
  85.  
  86.   { TFileList is a TSortedList box that assumes it contains     }
  87.   { a TFileCollection as its collection.  It also communicates  }
  88.   { through broadcast messages to TFileInput and TInfoPane      }
  89.   { what file is currently selected.                            }
  90.  
  91.   PFileList = ^TFileList;
  92.   TFileList = object(TSortedListBox)
  93.     constructor Init(var Bounds: TRect; AWildCard: PathStr;
  94.       AScrollBar: PScrollBar);
  95.     destructor Done; virtual;
  96.     function DataSize: Word; virtual;
  97.     procedure FocusItem(Item: Integer); virtual;
  98.     procedure GetData(var Rec); virtual;
  99.     function GetText(Item: Integer; MaxLen: Integer): String; virtual;
  100.     function GetKey(var S: String): Pointer; virtual;
  101.     procedure HandleEvent(var Event: TEvent); virtual;
  102.     procedure ReadDirectory(AWildCard: PathStr);
  103.     procedure SetData(var Rec); virtual;
  104.   end;
  105.  
  106.   { TFileInfoPane is a TView that displays the information      }
  107.   { about the currently selected file in the TFileList          }
  108.   { of a TFileDialog.                                           }
  109.  
  110.   PFileInfoPane = ^TFileInfoPane;
  111.   TFileInfoPane = object(TView)
  112.     S: TSearchRec;
  113.     constructor Init(var Bounds: TRect);
  114.     procedure Draw; virtual;
  115.     function GetPalette: PPalette; virtual;
  116.     procedure HandleEvent(var Event: TEvent); virtual;
  117.   end;
  118.  
  119.   { TFileDialog is a standard file name input dialog            }
  120.  
  121.   TWildStr = PathStr;
  122.  
  123. const
  124.   fdOkButton      = $0001;      { Put an OK button in the dialog }
  125.   fdOpenButton    = $0002;      { Put an Open button in the dialog }
  126.   fdReplaceButton = $0004;      { Put a Replace button in the dialog }
  127.   fdClearButton   = $0008;      { Put a Clear button in the dialog }
  128.   fdHelpButton    = $0010;      { Put a Help button in the dialog }
  129.   fdNoLoadDir     = $0100;      { Do not load the current directory }
  130.                                 { contents into the dialog at Init. }
  131.                                 { This means you intend to change the }
  132.                                 { WildCard by using SetData or store }
  133.                                 { the dialog on a stream. }
  134.  
  135. type
  136.  
  137.   PFileDialog = ^TFileDialog;
  138.   TFileDialog = object(TDialog)
  139.     FileName: PFileInputLine;
  140.     FileList: PFileList;
  141.     WildCard: TWildStr;
  142.     Directory: PString;
  143.     constructor Init(AWildCard: TWildStr; ATitle: String;
  144.       InputName: String; AOptions: Word; HistoryId: Byte);
  145.     constructor Load(var S: TStream);
  146.     destructor Done; virtual;
  147.     procedure GetData(var Rec); virtual;
  148.     procedure GetFileName(var S: PathStr);
  149.     procedure HandleEvent(var Event: TEvent); virtual;
  150.     procedure SetData(var Rec); virtual;
  151.     procedure Store(var S: TStream);
  152.     function Valid(Command: Word): Boolean; virtual;
  153.   private
  154.     procedure ReadDirectory;
  155.   end;
  156.  
  157.   { TDirEntry }
  158.  
  159.   PDirEntry = ^TDirEntry;
  160.   TDirEntry = record
  161.     DisplayText: PString;
  162.     Directory: PString;
  163.   end;
  164.  
  165.   { TDirCollection is a collection of TDirEntry's used by       }
  166.   { TDirListBox.                                                }
  167.  
  168.   PDirCollection = ^TDirCollection;
  169.   TDirCollection = object(TCollection)
  170.     function GetItem(var S: TStream): Pointer; virtual;
  171.     procedure FreeItem(Item: Pointer); virtual;
  172.     procedure PutItem(var S: TStream; Item: Pointer); virtual;
  173.   end;
  174.  
  175.   { TDirListBox displays a tree of directories for use in the }
  176.   { TChDirDialog.                                               }
  177.  
  178.   PDirListBox = ^TDirListBox;
  179.   TDirListBox = object(TListBox)
  180.     Dir: DirStr;
  181.     Cur: Word;
  182.     constructor Init(var Bounds: TRect; AScrollBar: PScrollBar);
  183.     destructor Done; virtual;
  184.     function GetText(Item: Integer; MaxLen: Integer): String; virtual;
  185.     procedure HandleEvent(var Event: TEvent); virtual;
  186.     function IsSelected(Item: Integer): Boolean; virtual;
  187.     procedure NewDirectory(var ADir: DirStr);
  188.     procedure SetState(AState: Word; Enable: Boolean); virtual;
  189.   end;
  190.  
  191.   { TChDirDialog is a standard change directory dialog.         }
  192.  
  193. const
  194.   cdNormal     = $0000; { Option to use dialog immediately }
  195.   cdNoLoadDir  = $0001; { Option to init the dialog to store on a stream }
  196.   cdHelpButton = $0002; { Put a help button in the dialog }
  197.  
  198. type
  199.  
  200.   PChDirDialog = ^TChDirDialog;
  201.   TChDirDialog = object(TDialog)
  202.     DirInput: PInputLine;
  203.     DirList: PDirListBox;
  204.     OkButton: PButton;
  205.     ChDirButton: PButton;
  206.     constructor Init(AOptions: Word; HistoryId: Word);
  207.     constructor Load(var S: TStream);
  208.     function DataSize: Word; virtual;
  209.     procedure GetData(var Rec); virtual;
  210.     procedure HandleEvent(var Event: TEvent); virtual;
  211.     procedure SetData(var Rec); virtual;
  212.     procedure Store(var S: TStream);
  213.     function Valid(Command: Word): Boolean; virtual;
  214.   private
  215.     procedure SetUpDialog;
  216.   end;
  217.  
  218. const
  219.  
  220.   CInfoPane = #30;
  221.  
  222.   { TStream registration records }
  223.  
  224.   RFileInputLine: TStreamRec = (
  225.      ObjType: 60;
  226.      VmtLink: Ofs(TypeOf(TFileInputLine)^);
  227.      Load:    @TFileInputLine.Load;
  228.      Store:   @TFileInputLine.Store
  229.   );
  230.   RFileCollection: TStreamRec = (
  231.      ObjType: 61;
  232.      VmtLink: Ofs(TypeOf(TFileCollection)^);
  233.      Load:    @TFileCollection.Load;
  234.      Store:   @TFileCollection.Store
  235.   );
  236.   RFileList: TStreamRec = (
  237.      ObjType: 62;
  238.      VmtLink: Ofs(TypeOf(TFileList)^);
  239.      Load:    @TFileList.Load;
  240.      Store:   @TFileList.Store
  241.   );
  242.   RFileInfoPane: TStreamRec = (
  243.      ObjType: 63;
  244.      VmtLink: Ofs(TypeOf(TFileInfoPane)^);
  245.      Load:    @TFileInfoPane.Load;
  246.      Store:   @TFileInfoPane.Store
  247.   );
  248.   RFileDialog: TStreamRec = (
  249.      ObjType: 64;
  250.      VmtLink: Ofs(TypeOf(TFileDialog)^);
  251.      Load:    @TFileDialog.Load;
  252.      Store:   @TFileDialog.Store
  253.   );
  254.   RDirCollection: TStreamRec = (
  255.      ObjType: 65;
  256.      VmtLink: Ofs(TypeOf(TDirCollection)^);
  257.      Load:    @TDirCollection.Load;
  258.      Store:   @TDirCollection.Store
  259.   );
  260.   RDirListBox: TStreamRec = (
  261.      ObjType: 66;
  262.      VmtLink: Ofs(TypeOf(TDirListBox)^);
  263.      Load:    @TDirListBox.Load;
  264.      Store:   @TDirListBox.Store
  265.   );
  266.   RChDirDialog: TStreamRec = (
  267.      ObjType: 67;
  268.      VmtLink: Ofs(TypeOf(TChDirDialog)^);
  269.      Load:    @TChDirDialog.Load;
  270.      Store:   @TChDirDialog.Store
  271.   );
  272.  
  273. procedure RegisterStdDlg;
  274.  
  275. implementation
  276.  
  277. uses App, Memory, HistList, MsgBox;
  278.  
  279. function DriveValid(Drive: Char): Boolean; assembler;
  280. asm
  281.         CALL    DosVersion
  282.         CMP     AL,3
  283.         JL      @@0
  284.         MOV     AX,4408H
  285.     MOV    BL,Drive
  286.         SUB    BL,'A'-1
  287.         INT     21H
  288.         JNC     @@1
  289. @@0:    MOV    AH,36H
  290.         MOV     DL,Drive
  291.         SUB    DL,'A'-1
  292.         INT    21H
  293.         INC    AX
  294.         JE    @@2
  295. @@1:    MOV    AL,1
  296. @@2:
  297. end;
  298.  
  299. function PathValid(var Path: PathStr): Boolean;
  300. var
  301.   ExpPath: PathStr;
  302.   F: File;
  303.   SR: SearchRec;
  304. begin
  305.   ExpPath := FExpand(Path);
  306.   if Length(ExpPath) <= 3 then PathValid := DriveValid(ExpPath[1])
  307.   else
  308.   begin
  309.     if ExpPath[Length(ExpPath)] = '\' then Dec(ExpPath[0]);
  310.     FindFirst(ExpPath, Directory, SR);
  311.     PathValid := (DosError = 0) and (SR.Attr and Directory <> 0);
  312.   end;
  313. end;
  314.  
  315. function ValidFileName(var FileName: PathStr): Boolean;
  316. const
  317.   IllegalChars = ';,=+<>|"[] \';
  318. var
  319.   Dir: DirStr;
  320.   Name: NameStr;
  321.   Ext: ExtStr;
  322.  
  323. { Contains returns true if S1 contains any characters in S2 }
  324. function Contains(S1, S2: String): Boolean; near; assembler;
  325. asm
  326.     PUSH    DS
  327.         CLD
  328.         LDS    SI,S1
  329.         LES    DI,S2
  330.         MOV    DX,DI
  331.         XOR    AH,AH
  332.         LODSB
  333.         MOV    BX,AX
  334.         OR      BX,BX
  335.         JZ      @@2
  336.         MOV    AL,ES:[DI]
  337.         XCHG    AX,CX
  338. @@1:    PUSH    CX
  339.     MOV    DI,DX
  340.     LODSB
  341.         REPNE    SCASB
  342.         POP    CX
  343.         JE    @@3
  344.     DEC    BX
  345.         JNZ    @@1
  346. @@2:    XOR    AL,AL
  347.     JMP    @@4
  348. @@3:    MOV    AL,1
  349. @@4:    POP    DS
  350. end;
  351.  
  352. begin
  353.   ValidFileName := True;
  354.   FSplit(FileName, Dir, Name, Ext);
  355.   if not ((Dir = '') or PathValid(Dir)) or Contains(Name, IllegalChars) or
  356.     Contains(Dir, IllegalChars) then ValidFileName := False;
  357. end;
  358.  
  359. function GetCurDir: DirStr;
  360. var
  361.   CurDir: DirStr;
  362. begin
  363.   GetDir(0, CurDir);
  364.   if Length(CurDir) > 3 then
  365.   begin
  366.     Inc(CurDir[0]);
  367.     CurDir[Length(CurDir)] := '\';
  368.   end;
  369.   GetCurDir := CurDir;
  370. end;
  371.  
  372. type
  373.   PSearchRec = ^TSearchRec;
  374.  
  375. function IsWild(var S: String): Boolean;
  376. begin
  377.   IsWild := (Pos('?',S) > 0) or (Pos('*',S) > 0);
  378. end;
  379.  
  380. function IsDir(var S: String): Boolean;
  381. var
  382.   SR: SearchRec;
  383. begin
  384.   FindFirst(S, Directory, SR);
  385.   if DosError = 0 then
  386.     IsDir := SR.Attr and Directory <> 0
  387.   else IsDir := False;
  388. end;
  389.  
  390. { TFileInputLine }
  391.  
  392. constructor TFileInputLine.Init(var Bounds: TRect; AMaxLen: Integer);
  393. begin
  394.   TInputLine.Init(Bounds, AMaxLen);
  395.   EventMask := EventMask or evBroadcast;
  396. end;
  397.  
  398. procedure TFileInputLine.HandleEvent(var Event: TEvent);
  399. var
  400.   Dir: DirStr;
  401.   Name: NameStr;
  402.   Ext: ExtStr;
  403. begin
  404.   TInputLine.HandleEvent(Event);
  405.   if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) and
  406.     (State and sfSelected = 0) then
  407.   begin
  408.      if PSearchRec(Event.InfoPtr)^.Attr and Directory <> 0 then
  409.         Data^ := PSearchRec(Event.InfoPtr)^.Name + '\'+
  410.           PFileDialog(Owner)^.WildCard
  411.      else Data^ := PSearchRec(Event.InfoPtr)^.Name;
  412.      DrawView;
  413.   end;
  414. end;
  415.  
  416. { TFileCollection }
  417.  
  418. function TFileCollection.Compare(Key1, Key2: Pointer): Integer;
  419. begin
  420.   if PSearchRec(Key1)^.Name = PSearchRec(Key2)^.Name then Compare := 0
  421.   else if PSearchRec(Key1)^.Name = '..' then Compare := 1
  422.   else if PSearchRec(Key2)^.Name = '..' then Compare := -1
  423.   else if (PSearchRec(Key1)^.Attr and Directory <> 0) and
  424.      (PSearchRec(Key2)^.Attr and Directory = 0) then Compare := 1
  425.   else if (PSearchRec(Key2)^.Attr and Directory <> 0) and
  426.      (PSearchRec(Key1)^.Attr and Directory = 0) then Compare := -1
  427.   else if PSearchRec(Key1)^.Name > PSearchRec(Key2)^.Name then
  428.     Compare := 1
  429.   else Compare := -1;
  430. end;
  431.  
  432. procedure TFileCollection.FreeItem(Item: Pointer);
  433. begin
  434.   Dispose(PSearchRec(Item));
  435. end;
  436.  
  437. function TFileCollection.GetItem(var S: TStream): Pointer;
  438. var
  439.   Item: PSearchRec;
  440. begin
  441.   New(Item);
  442.   S.Read(Item^, SizeOf(TSearchRec));
  443.   GetItem := Item;
  444. end;
  445.  
  446. procedure TFileCollection.PutItem(var S: TStream; Item: Pointer);
  447. begin
  448.   S.Write(Item^, SizeOf(TSearchRec));
  449. end;
  450.  
  451. { TSortedListBox }
  452.  
  453. constructor TSortedListBox.Init(var Bounds: TRect; ANumCols: Word;
  454.   AScrollBar: PScrollBar);
  455. begin
  456.   TListBox.Init(Bounds, ANumCols, AScrollBar);
  457.   SearchPos := 0;
  458.   ShowCursor;
  459.   SetCursor(1,0);
  460. end;
  461.  
  462. procedure TSortedListBox.HandleEvent(var Event: TEvent);
  463. var
  464.   ShiftKeys: Byte absolute $40:$17;
  465.   CurString, NewString: String;
  466.   K: Pointer;
  467.   Value, OldPos, OldValue: Integer;
  468.   T: Boolean;
  469.  
  470. function Equal(var S1: String; var S2: String; Count: Word): Boolean;
  471. var
  472.   I: Word;
  473. begin
  474.   Equal := False;
  475.   if (Length(S1) < Count) or (Length(S2) < Count) then Exit;
  476.   for I := 1 to Count do
  477.     if UpCase(S1[I]) <> UpCase(S2[I]) then Exit;
  478.   Equal := True;
  479. end;
  480.  
  481. begin
  482.   OldValue := Focused;
  483.   TListBox.HandleEvent(Event);
  484.   if OldValue <> Focused then SearchPos := 0;
  485.   if Event.What = evKeyDown then
  486.   begin
  487.     if Event.CharCode <> #0 then
  488.     begin
  489.       Value := Focused;
  490.       if Value < Range then CurString := GetText(Value, 255)
  491.       else CurString := '';
  492.       OldPos := SearchPos;
  493.       if Event.KeyCode = kbBack then
  494.       begin
  495.         if SearchPos = 0 then Exit;
  496.         Dec(SearchPos);
  497.         if SearchPos = 0 then ShiftState := ShiftKeys;
  498.         CurString[0] := Char(SearchPos);
  499.       end
  500.       else if (Event.CharCode = '.') then SearchPos := Pos('.',CurString)
  501.       else
  502.       begin
  503.         Inc(SearchPos);
  504.         if SearchPos = 1 then ShiftState := ShiftKeys;
  505.         CurString[0] := Char(SearchPos);
  506.         CurString[SearchPos] := Event.CharCode;
  507.       end;
  508.       K := GetKey(CurString);
  509.       T := PSortedCollection(List)^.Search(K, Value);
  510.       if Value < Range then
  511.       begin
  512.         if Value < Range then NewString := GetText(Value, 255)
  513.         else NewString := '';
  514.         if Equal(NewString, CurString, SearchPos) then
  515.         begin
  516.           if Value <> OldValue then
  517.           begin
  518.             FocusItem(Value);
  519.             { Assumes ListControl will set the cursor to the first character }
  520.             { of the sfFocused item }
  521.             SetCursor(Cursor.X+SearchPos, Cursor.Y);
  522.           end
  523.           else SetCursor(Cursor.X+(SearchPos-OldPos), Cursor.Y);
  524.         end
  525.         else SearchPos := OldPos;
  526.       end
  527.       else SearchPos := OldPos;
  528.       if (SearchPos <> OldPos) or (Event.CharCode in ['A'..'Z','a'..'z']) then
  529.         ClearEvent(Event);
  530.     end;
  531.   end;
  532. end;
  533.  
  534. function TSortedListBox.GetKey(var S: String): Pointer;
  535. begin
  536.   GetKey := @S;
  537. end;
  538.  
  539. procedure TSortedListBox.NewList(AList: PCollection);
  540. begin
  541.   TListBox.NewList(AList);
  542.   SearchPos := 0;
  543. end;
  544.  
  545. { TFileList }
  546.  
  547. constructor TFileList.Init(var Bounds: TRect; AWildCard: PathStr;
  548.   AScrollBar: PScrollBar);
  549. begin
  550.   TSortedListBox.Init(Bounds, 2, AScrollBar);
  551. end;
  552.  
  553. destructor TFileList.Done;
  554. begin
  555.   if List <> nil then Dispose(List, Done);
  556.   TListBox.Done;
  557. end;
  558.  
  559. function TFileList.DataSize: Word;
  560. begin
  561.   DataSize := 0;
  562. end;
  563.  
  564. procedure TFileList.FocusItem(Item: Integer);
  565. begin
  566.   TSortedListBox.FocusItem(Item);
  567.   Message(Owner, evBroadcast, cmFileFocused, List^.At(Item));
  568. end;
  569.  
  570. procedure TFileList.GetData(var Rec);
  571. begin
  572. end;
  573.  
  574. function TFileList.GetKey(var S: String): Pointer;
  575. const
  576.   SR: TSearchRec = ();
  577.  
  578. procedure UpStr(var S: String);
  579. var
  580.   I: Integer;
  581. begin
  582.   for I := 1 to Length(S) do S[I] := UpCase(S[I]);
  583. end;
  584.  
  585. begin
  586.   if (ShiftState and $03 <> 0) or ((S <> '') and (S[1]='.')) then
  587.     SR.Attr := Directory
  588.   else SR.Attr := 0;
  589.   SR.Name := S;
  590.   UpStr(SR.Name);
  591.   GetKey := @SR;
  592. end;
  593.  
  594. function TFileList.GetText(Item: Integer; MaxLen: Integer): String;
  595. var
  596.   S: String;
  597.   SR: PSearchRec;
  598. begin
  599.   SR := PSearchRec(List^.At(Item));
  600.   S := SR^.Name;
  601.   if SR^.Attr and Directory <> 0 then
  602.   begin
  603.     S[Length(S)+1] := '\';
  604.     Inc(S[0]);
  605.   end;
  606.   GetText := S;
  607. end;
  608.  
  609. procedure TFileList.HandleEvent(var Event: TEvent);
  610. begin
  611.   if (Event.What = evMouseDown) and (Event.Double) then
  612.   begin
  613.     Event.What := evCommand;
  614.     Event.Command := cmOK;
  615.     PutEvent(Event);
  616.     ClearEvent(Event);
  617.   end
  618.   else TSortedListBox.HandleEvent(Event);
  619. end;
  620.  
  621. procedure TFileList.ReadDirectory(AWildCard: PathStr);
  622. const
  623.   FindAttr = ReadOnly + Archive;
  624.   AllFiles = '*.*';
  625.   PrevDir  = '..';
  626. var
  627.   S: SearchRec;
  628.   P: PSearchRec;
  629.   FileList: PFileCollection;
  630.   NumFiles: Word;
  631.   CurPath: PathStr;
  632.   Dir: DirStr;
  633.   Name: NameStr;
  634.   Ext: ExtStr;
  635.   Event: TEvent;
  636.   Tmp: PathStr;
  637.   Flag: Integer;
  638. begin
  639.   NumFiles := 0;
  640.   AWildCard := FExpand(AWildCard);
  641.   FSplit(AWildCard, Dir, Name, Ext);
  642.   FileList := New(PFileCollection, Init(5, 5));
  643.   FindFirst(AWildCard, FindAttr, S);
  644.   P := @P;
  645.   while (P <> nil) and (DosError = 0) do
  646.   begin
  647.     if (S.Attr and Directory = 0) then
  648.     begin
  649.       P := MemAlloc(SizeOf(P^));
  650.       if P <> nil then
  651.       begin
  652.         Move(S.Attr, P^, SizeOf(P^));
  653.         FileList^.Insert(P);
  654.       end;
  655.     end;
  656.     FindNext(S);
  657.   end;
  658.   Tmp := Dir + AllFiles;
  659.   FindFirst(Tmp, Directory, S);
  660.   while (P <> nil) and (DosError = 0) do
  661.   begin
  662.     if (S.Attr and Directory <> 0) and (S.Name[1] <> '.') then
  663.     begin
  664.       P := MemAlloc(SizeOf(P^));
  665.       if P <> nil then
  666.       begin
  667.         Move(S.Attr, P^, SizeOf(P^));
  668.         FileList^.Insert(PObject(P));
  669.       end;
  670.     end;
  671.     FindNext(S);
  672.   end;
  673.   if Length(Dir) > 4 then
  674.   begin
  675.     P := MemAlloc(SizeOf(P^));
  676.     if P <> nil then
  677.     begin
  678.       FindFirst(Tmp, Directory, S);
  679.       FindNext(S);
  680.       if (DosError = 0) and (S.Name = PrevDir) then
  681.         Move(S.Attr, P^, SizeOf(P^))
  682.       else
  683.       begin
  684.         P^.Name := PrevDir;
  685.         P^.Size := 0;
  686.         P^.Time := $210000;
  687.         P^.Attr := Directory;
  688.       end;
  689.       FileList^.Insert(PObject(P));
  690.     end;
  691.   end;
  692.   if P = nil then MessageBox('Too many files.', nil, mfOkButton + mfWarning);
  693.   NewList(FileList);
  694.   if List^.Count > 0 then
  695.   begin
  696.     Event.What := evBroadcast;
  697.     Event.Command := cmFileFocused;
  698.     Event.InfoPtr := List^.At(0);
  699.     Owner^.HandleEvent(Event);
  700.   end;
  701. end;
  702.  
  703. procedure TFileList.SetData(var Rec);
  704. begin
  705.   with PFileDialog(Owner)^ do
  706.     Self.ReadDirectory(Directory^ + WildCard);
  707. end;
  708.  
  709. { TFileInfoPane }
  710.  
  711. constructor TFileInfoPane.Init(var Bounds: TRect);
  712. begin
  713.   TView.Init(Bounds);
  714.   EventMask := EventMask or evBroadcast;
  715. end;
  716.  
  717. procedure TFileInfoPane.Draw;
  718. var
  719.   B: TDrawBuffer;
  720.   D: String[9];
  721.   M: String[3];
  722.   PM: Boolean;
  723.   Color: Word;
  724.   Time: DateTime;
  725.   Path: PathStr;
  726.   FmtId: String;
  727.   Params: array[0..7] of LongInt;
  728.   Str: String[80];
  729. const
  730.   sDirectoryLine = ' %-12s %-9s %3s %2d, %4d  %2d:%02d%cm';
  731.   sFileLine      = ' %-12s %-9d %3s %2d, %4d  %2d:%02d%cm';
  732.   Month: array[1..12] of String[3] = 
  733.     ('Jan','Feb','Mar','Apr','May','Jun',
  734.      'Jul','Aug','Sep','Oct','Nov','Dec');
  735. begin
  736.   { Display path }
  737.   Path := FExpand(PFileDialog(Owner)^.Directory^+PFileDialog(Owner)^.WildCard);
  738.   Color := GetColor($01);
  739.   MoveChar(B, ' ', Color, Size.X);
  740.   MoveStr(B[1], Path, Color);
  741.   WriteLine(0, 0, Size.X, 1, B);
  742.  
  743.   { Display file }
  744.   Params[0] := LongInt(@S.Name);
  745.   MoveChar(B, ' ', Color, Size.X);
  746.   Params[0] := LongInt(@S.Name);
  747.   if S.Attr and Directory <> 0 then
  748.   begin
  749.     FmtId := sDirectoryLine;
  750.     D := 'Directory';
  751.     Params[1] := LongInt(@D);
  752.   end else
  753.   begin
  754.     FmtId := sFileLine;
  755.     Params[1] := S.Size;
  756.   end;
  757.   UnpackTime(S.Time, Time);
  758.   M := Month[Time.Month];
  759.   Params[2] := LongInt(@M);
  760.   Params[3] := Time.Day;
  761.   Params[4] := Time.Year;
  762.   PM := Time.Hour >= 12;
  763.   Time.Hour := Time.Hour mod 12;
  764.   if Time.Hour = 0 then Time.Hour := 12;
  765.   Params[5] := Time.Hour;
  766.   Params[6] := Time.Min;
  767.   if PM then Params[7] := Byte('p')
  768.   else Params[7] := Byte('a');
  769.   FormatStr(Str, FmtId, Params);
  770.   MoveStr(B, Str, Color);
  771.   WriteLine(0, 1, Size.X, 1, B);
  772.  
  773.   { Fill in rest of rectangle }
  774.   MoveChar(B, ' ', Color, Size.X);
  775.   WriteLine(0, 2, Size.X, Size.Y-2, B);
  776. end;
  777.  
  778. function TFileInfoPane.GetPalette: PPalette;
  779. const
  780.   P: String[Length(CInfoPane)] = CInfoPane;
  781. begin
  782.   GetPalette := @P;
  783. end;
  784.  
  785. procedure TFileInfoPane.HandleEvent(var Event: TEvent);
  786. begin
  787.   TView.HandleEvent(Event);
  788.   if (Event.What = evBroadcast) and (Event.Command = cmFileFocused) then
  789.   begin
  790.     S := PSearchRec(Event.InfoPtr)^;
  791.     DrawView;
  792.   end;
  793. end;
  794.  
  795. { TFileDialog }
  796.  
  797. constructor TFileDialog.Init(AWildCard: TWildStr; ATitle: String;
  798.   InputName: String; AOptions: Word; HistoryId: Byte);
  799. var
  800.   Control: PView;
  801.   R: TRect;
  802.   S: String;
  803.   Opt: Word;
  804.   ACurDir: PathStr;
  805. begin
  806.   R.Assign(15,1,64,20);
  807.   TDialog.Init(R, ATitle);
  808.   Options := Options or ofCentered;
  809.   WildCard := AWildCard;
  810.  
  811.   R.Assign(3,3,31,4);
  812.   FileName := New(PFileInputLine, Init(R, 79));
  813.   FileName^.Data^ := WildCard;
  814.   Insert(FileName);
  815.   R.Assign(2,2,3+CStrLen(InputName),3);
  816.   Control := New(PLabel, Init(R, InputName, FileName));
  817.   Insert(Control);
  818.   R.Assign(31,3,34,4);
  819.   Control := New(PHistory, Init(R, FileName, HistoryId));
  820.   Insert(Control);
  821.  
  822.   R.Assign(3,14,34,15);
  823.   Control := New(PScrollBar, Init(R));
  824.   Insert(Control);
  825.   R.Assign(3,6,34,14);
  826.   FileList := New(PFileList, Init(R, WildCard, PScrollBar(Control)));
  827.   Insert(FileList);
  828.   R.Assign(2,5,8,6);
  829.   Control := New(PLabel, Init(R, '~F~iles', FileList));
  830.   Insert(Control);
  831.  
  832.   R.Assign(35,3,46,5);
  833.   Opt := bfDefault;
  834.   if AOptions and fdOpenButton <> 0 then
  835.   begin
  836.     Insert(New(PButton, Init(R, '~O~pen', cmFileOpen, Opt)));
  837.     Opt := bfNormal;
  838.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  839.   end;
  840.   if AOptions and fdOkButton <> 0 then
  841.   begin
  842.     Insert(New(PButton, Init(R, 'O~K~', cmFileOpen, Opt)));
  843.     Opt := bfNormal;
  844.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  845.   end;
  846.   if AOptions and fdReplaceButton <> 0 then
  847.   begin
  848.     Insert(New(PButton, Init(R, '~R~eplace',cmFileReplace, Opt)));
  849.     Opt := bfNormal;
  850.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  851.   end;
  852.   if AOptions and fdClearButton <> 0 then
  853.   begin
  854.     Insert(New(PButton, Init(R, '~C~lear',cmFileClear, Opt)));
  855.     Opt := bfNormal;
  856.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  857.   end;
  858.   Insert(New(PButton, Init(R, 'Cancel', cmCancel, bfNormal)));
  859.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  860.   if AOptions and fdHelpButton <> 0 then
  861.   begin
  862.     Insert(New(PButton, Init(R, 'Help',cmHelp, bfNormal)));
  863.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  864.   end;
  865.  
  866.   R.Assign(1,16,48,18);
  867.   Control := New(PFileInfoPane, Init(R));
  868.   Insert(Control);
  869.  
  870.   SelectNext(False);
  871.  
  872.   if AOptions and fdNoLoadDir = 0 then ReadDirectory;
  873. end;
  874.  
  875. constructor TFileDialog.Load(var S: TStream);
  876. var
  877.   ACurDir: DirStr;
  878.   ViewId: Word;
  879. begin
  880.   TDialog.Load(S);
  881.   S.Read(WildCard, SizeOf(TWildStr));
  882.   GetSubViewPtr(S, FileName);
  883.   GetSubViewPtr(S, FileList);
  884.  
  885.   ReadDirectory;
  886. end;
  887.  
  888. destructor TFileDialog.Done;
  889. begin
  890.   DisposeStr(Directory);
  891.   TDialog.Done;
  892. end;
  893.  
  894. procedure TFileDialog.GetData(var Rec);
  895. begin
  896.   GetFilename(PathStr(Rec));
  897. end;
  898.  
  899. procedure TFileDialog.GetFileName(var S: PathStr);
  900. var
  901.   Path: PathStr;
  902.   Name: NameStr;
  903.   Ext: ExtStr;
  904.   TPath: PathStr;
  905.   TName: NameStr;
  906.   TExt: NameStr;
  907.  
  908. function LTrim(S: String): String;
  909. var
  910.   I: Integer;
  911. begin
  912.   I := 1;
  913.   while (I < Length(S)) and (S[I] = ' ') do Inc(I);
  914.   LTrim := Copy(S, I, 255);
  915. end;
  916.  
  917. function RTrim(S: String): String;
  918. var
  919.   I: Integer;
  920. begin
  921.   while S[Length(S)] = ' ' do Dec(S[0]);
  922.   RTrim := S;
  923. end;
  924.  
  925. function RelativePath(var S: PathStr): Boolean;
  926. var
  927.   I,J: Integer;
  928.   P: PathStr;
  929. begin
  930.   S := LTrim(RTrim(S));
  931.   if (S <> '') and ((S[1] = '\') or (S[2] = ':')) then RelativePath := False
  932.   else RelativePath := True;
  933. end;
  934.  
  935. function NoWildChars(S: String): String; assembler;
  936. asm
  937.     PUSH    DS
  938.     LDS    SI,S
  939.         XOR     AX,AX
  940.     LODSB
  941.     XCHG    AX,CX
  942.         LES     DI,@Result
  943.         INC     DI
  944.         JCXZ    @@3
  945. @@1:    LODSB
  946.     CMP    AL,'?'
  947.     JE    @@2
  948.     CMP    AL,'*'
  949.     JE    @@2
  950.     STOSB
  951. @@2:    LOOP    @@1
  952. @@3:    XCHG    AX,DI
  953.     MOV    DI,WORD PTR @Result
  954.     SUB    AX,DI
  955.         DEC     AX
  956.         STOSB
  957.     POP    DS
  958. end;
  959.  
  960. begin
  961.   S := FileName^.Data^;
  962.   if RelativePath(S) then S := FExpand(Directory^ + S)
  963.   else S := FExpand(S);
  964.   FSplit(S, Path, Name, Ext);
  965.   if ((Name = '') or (Ext = '')) and not IsDir(S) then
  966.   begin
  967.     FSplit(WildCard, TPath, TName, TExt);
  968.     if ((Name = '') and (Ext = '')) then S := Path + TName + TExt
  969.     else if Name = '' then S := Path + TName + Ext
  970.     else if Ext = '' then
  971.     begin
  972.       if IsWild(Name) then S := Path + Name + TExt
  973.       else S := Path + Name + NoWildChars(TExt);
  974.     end;
  975.   end;
  976. end;
  977.  
  978. procedure TFileDialog.HandleEvent(var Event: TEvent);
  979. begin
  980.   TDialog.HandleEvent(Event);
  981.   if Event.What = evCommand then
  982.     case Event.Command of
  983.       cmFileOpen, cmFileReplace, cmFileClear:
  984.         begin
  985.           EndModal(Event.Command);
  986.           ClearEvent(Event);
  987.         end;
  988.     end;
  989. end;
  990.  
  991. procedure TFileDialog.SetData(var Rec);
  992. begin
  993.   TDialog.SetData(Rec);
  994.   if (PathStr(Rec) <> '') and (IsWild(TWildStr(Rec))) then
  995.   begin
  996.     Valid(cmFileInit);
  997.     FileName^.Select;
  998.   end;
  999. end;
  1000.  
  1001. procedure TFileDialog.ReadDirectory;
  1002. begin
  1003.   FileList^.ReadDirectory(WildCard);
  1004.   Directory := NewStr(GetCurDir);
  1005. end;
  1006.  
  1007. procedure TFileDialog.Store(var S: TStream);
  1008. begin
  1009.   TDialog.Store(S);
  1010.   S.Write(WildCard, SizeOf(TWildStr));
  1011.   PutSubViewPtr(S, FileName);
  1012.   PutSubViewPtr(S, FileList);
  1013. end;
  1014.  
  1015. function TFileDialog.Valid(Command: Word): Boolean;
  1016. var
  1017.   T: Boolean;
  1018.   FName: PathStr;
  1019.   Dir: DirStr;
  1020.   Name: NameStr;
  1021.   Ext: ExtStr;
  1022.  
  1023. function CheckDirectory(var S: PathStr): Boolean;
  1024. begin
  1025.   if not PathValid(S) then
  1026.   begin
  1027.     MessageBox('Invalid drive or directory.', nil, mfError + mfOkButton);
  1028.     FileName^.Select;
  1029.     CheckDirectory := False;
  1030.   end else CheckDirectory := True;
  1031. end;
  1032.  
  1033. begin
  1034.   if Command = 0 then
  1035.   begin
  1036.     Valid := True;
  1037.     Exit;
  1038.   end else Valid := False;
  1039.   if TDialog.Valid(Command) then
  1040.   begin
  1041.     GetFileName(FName);
  1042.     if (Command <> cmCancel) and (Command <> cmFileClear) then
  1043.     begin
  1044.       if IsWild(FName) then
  1045.       begin
  1046.         FSplit(FName, Dir, Name, Ext);
  1047.         if CheckDirectory(Dir) then
  1048.         begin
  1049.           DisposeStr(Directory);
  1050.           Directory := NewStr(Dir);
  1051.           WildCard := Name+Ext;
  1052.           if Command <> cmFileInit then FileList^.Select;
  1053.           FileList^.ReadDirectory(Directory^+WildCard);
  1054.         end
  1055.       end
  1056.       else if IsDir(FName) then
  1057.       begin
  1058.         if CheckDirectory(FName) then
  1059.         begin
  1060.           DisposeStr(Directory);
  1061.       Directory := NewSTr(FName+'\');
  1062.       if Command <> cmFileInit then FileList^.Select;
  1063.       FileList^.ReadDirectory(Directory^+WildCard);
  1064.         end
  1065.       end else if ValidFileName(FName) then Valid := True
  1066.       else
  1067.       begin
  1068.         MessageBox('Invalid file name.', nil, mfError + mfOkButton);
  1069.         Valid := False;
  1070.       end
  1071.     end
  1072.     else Valid := True;
  1073.   end;
  1074. end;
  1075.  
  1076. { TDirCollection }
  1077.  
  1078. function TDirCollection.GetItem(var S: TStream): Pointer;
  1079. var
  1080.   DirItem: PDirEntry;
  1081. begin
  1082.   New(DirItem);
  1083.   DirItem^.DisplayText := S.ReadStr;
  1084.   DirItem^.Directory := S.ReadStr;
  1085.   GetItem := DirItem;
  1086. end;
  1087.  
  1088. procedure TDirCollection.FreeItem(Item: Pointer);
  1089. var
  1090.   DirItem: PDirEntry absolute Item;
  1091. begin
  1092.   DisposeStr(DirItem^.DisplayText);
  1093.   DisposeStr(DirItem^.Directory);
  1094.   Dispose(DirItem);
  1095. end;
  1096.  
  1097. procedure TDirCollection.PutItem(var S: TStream; Item: Pointer);
  1098. var
  1099.   DirItem: PDirEntry absolute Item;
  1100. begin
  1101.   S.WriteStr(DirItem^.DisplayText);
  1102.   S.WriteStr(DirItem^.Directory);
  1103. end;
  1104.  
  1105. { TDirListBox }
  1106.  
  1107. const
  1108.   DrivesS: String[6] = 'Drives';
  1109.   Drives: PString = @DrivesS;
  1110.  
  1111. constructor TDirListBox.Init(var Bounds: TRect; AScrollBar:
  1112.   PScrollBar);
  1113. begin
  1114.   TListBox.Init(Bounds, 1, AScrollBar);
  1115.   Dir := '';
  1116. end;
  1117.  
  1118. destructor TDirListBox.Done;
  1119. begin
  1120.   if List <> nil then Dispose(List, Done);
  1121.   TListBox.Done;
  1122. end;
  1123.  
  1124. function TDirListBox.GetText(Item: Integer; MaxLen: Integer): String;
  1125. begin
  1126.   GetText := PDirEntry(List^.At(Item))^.DisplayText^;
  1127. end;
  1128.  
  1129. procedure TDirListBox.HandleEvent(var Event: TEvent);
  1130. begin
  1131.   if (Event.What = evMouseDown) and (Event.Double) then
  1132.   begin
  1133.     Event.What := evCommand;
  1134.     Event.Command := cmChangeDir;
  1135.     PutEvent(Event);
  1136.     ClearEvent(Event);
  1137.   end
  1138.   else TListBox.HandleEvent(Event);
  1139. end;
  1140.  
  1141. function TDirListBox.IsSelected(Item: Integer): Boolean;
  1142. begin
  1143.   IsSelected := Item = Cur;
  1144. end;
  1145.  
  1146. procedure TDirListBox.NewDirectory(var ADir: DirStr);
  1147. const
  1148.   PathDir            = '└─┬';
  1149.   FirstDir           =   '└┬─';
  1150.   MiddleDir          =   ' ├─';
  1151.   LastDir            =   ' └─';
  1152.   IndentSize         = '  ';
  1153. var
  1154.   AList: PCollection;
  1155.   NewDir, Dirct: DirStr;
  1156.   C, OldC: Char;
  1157.   S, Indent: String[80];
  1158.   P: PString;
  1159.   isFirst: Boolean;
  1160.   SR: SearchRec;
  1161.   I: Integer;
  1162.   DirEntry: PDirEntry;
  1163.  
  1164. function NewDirEntry(DisplayText, Directory: String): PDirEntry; near;
  1165. var
  1166.   DirEntry: PDirEntry;
  1167. begin
  1168.   New(DirEntry);
  1169.   DirEntry^.DisplayText := NewStr(DisplayText);
  1170.   DirEntry^.Directory := NewStr(Directory);
  1171.   NewDirEntry := DirEntry;
  1172. end;
  1173.  
  1174. function GetCurDrive: Char; assembler;
  1175. asm
  1176.     MOV    AH,19H
  1177.         INT    21H
  1178.         ADD    AL,'A'
  1179. end;
  1180.  
  1181. begin
  1182.   Dir := ADir;
  1183.   AList := New(PDirCollection, Init(5,5));
  1184.   AList^.Insert(NewDirEntry(Drives^,Drives^));
  1185.   if Dir = Drives^ then
  1186.   begin
  1187.     isFirst := True;
  1188.     OldC := ' ';
  1189.     for C := 'A' to 'Z' do
  1190.     begin
  1191.       if (C < 'C') or DriveValid(C) then
  1192.       begin
  1193.         if OldC <> ' ' then
  1194.     begin
  1195.           if isFirst then
  1196.       begin
  1197.         S := FirstDir + OldC;
  1198.             isFirst := False;
  1199.           end
  1200.           else S := MiddleDir + OldC;
  1201.       AList^.Insert(NewDirEntry(S, OldC + ':\'));
  1202.         end;
  1203.         if C = GetCurDrive then Cur := AList^.Count;
  1204.         OldC := C;
  1205.       end;
  1206.     end;
  1207.     if OldC <> ' ' then AList^.Insert(NewDirEntry(LastDir + OldC, OldC + ':\'));
  1208.   end
  1209.   else
  1210.   begin
  1211.     Indent := IndentSize;
  1212.     NewDir := Dir;
  1213.     Dirct := Copy(NewDir,1,3);
  1214.     AList^.Insert(NewDirEntry(PathDir + Dirct, Dirct));
  1215.     NewDir := Copy(NewDir,4,255);
  1216.     while NewDir <> '' do
  1217.     begin
  1218.       I := Pos('\',NewDir);
  1219.       if I <> 0 then
  1220.       begin
  1221.         S := Copy(NewDir,1,I-1);
  1222.         Dirct := Dirct + S;
  1223.         AList^.Insert(NewDirEntry(Indent + PathDir + S, Dirct));
  1224.         NewDir := Copy(NewDir,I+1,255);
  1225.       end
  1226.       else
  1227.       begin
  1228.         Dirct := Dirct + NewDir;
  1229.         AList^.Insert(NewDirEntry(Indent + PathDir + NewDir, Dirct));
  1230.         NewDir := '';
  1231.       end;
  1232.       Indent := Indent + IndentSize;
  1233.       Dirct := Dirct + '\';
  1234.     end;
  1235.     Cur := AList^.Count-1;
  1236.     isFirst := True;
  1237.     NewDir := Dirct + '*.*';
  1238.     FindFirst(NewDir, Directory, SR);
  1239.     while DosError = 0 do
  1240.     begin
  1241.       if (SR.Attr and Directory <> 0) and (SR.Name[1] <> '.') then
  1242.       begin
  1243.         if isFirst then
  1244.     begin
  1245.       S := FirstDir;
  1246.       isFirst := False;
  1247.     end else S := MiddleDir;
  1248.         AList^.Insert(NewDirEntry(Indent + S + SR.Name, Dirct + SR.Name));
  1249.       end;
  1250.       FindNext(SR);
  1251.     end;
  1252.     P := PDirEntry(AList^.At(AList^.Count-1))^.DisplayText;
  1253.     I := Pos('└',P^);
  1254.     if I = 0 then
  1255.     begin
  1256.       I := Pos('├',P^);
  1257.       if I <> 0 then P^[I] := '└';
  1258.     end else
  1259.     begin
  1260.       P^[I+1] := '─';
  1261.       P^[I+2] := '─';
  1262.     end;
  1263.   end;
  1264.   NewList(AList);
  1265.   FocusItem(Cur);
  1266. end;
  1267.  
  1268. procedure TDirListBox.SetState(AState: Word; Enable: Boolean);
  1269. begin
  1270.   TListBox.SetState(AState, Enable);
  1271.   if AState and sfFocused <> 0 then
  1272.     PChDirDialog(Owner)^.ChDirButton^.MakeDefault(Enable);
  1273. end;
  1274.  
  1275. { TChDirDialog }
  1276.  
  1277. constructor TChDirDialog.Init(AOptions: Word; HistoryId: Word);
  1278. var
  1279.   R: TRect;
  1280.   Control: PView;
  1281.   CurDir: DirStr;
  1282. begin
  1283.   R.Assign(16, 2, 64, 20);
  1284.   TDialog.Init(R, 'Change Directory');
  1285.  
  1286.   Options := Options or ofCentered;
  1287.  
  1288.   R.Assign(3, 3, 30, 4);
  1289.   DirInput := New(PInputLine, Init(R, 68));
  1290.   Insert(DirInput);
  1291.   R.Assign(2, 2, 17, 3);
  1292.   Control := New(PLabel, Init(R, 'Directory ~n~ame', DirInput));
  1293.   Insert(Control);
  1294.   R.Assign(30, 3, 33, 4);
  1295.   Control := New(PHistory, Init(R, DirInput, HistoryId));
  1296.   Insert(Control);
  1297.  
  1298.   R.Assign(32, 6, 33, 16);
  1299.   Control := New(PScrollBar, Init(R));
  1300.   Insert(Control);
  1301.   R.Assign(3, 6, 32, 16);
  1302.   DirList := New(PDirListBox, Init(R, PScrollBar(Control)));
  1303.   Insert(DirList);
  1304.   R.Assign(2, 5, 17, 6);
  1305.   Control := New(PLabel, Init(R, 'Directory ~t~ree', DirList));
  1306.   Insert(Control);
  1307.  
  1308.   R.Assign(35, 6, 45, 8);
  1309.   OkButton := New(PButton, Init(R, 'O~K~', cmOK, bfDefault));
  1310.   Insert(OkButton);
  1311.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  1312.   ChDirButton := New(PButton, Init(R, '~C~hdir', cmChangeDir, bfNormal));
  1313.   Insert(ChDirButton);
  1314.   Inc(R.A.Y,3); Inc(R.B.Y,3);
  1315.   Insert(New(PButton, Init(R, '~R~evert', cmRevert, bfNormal)));
  1316.   if AOptions and cdHelpButton <> 0 then
  1317.   begin
  1318.     Inc(R.A.Y,3); Inc(R.B.Y,3);
  1319.     Insert(New(PButton, Init(R, 'Help', cmHelp, bfNormal)));
  1320.   end;
  1321.  
  1322.   if AOptions and cdNoLoadDir = 0 then SetUpDialog;
  1323.  
  1324.   SelectNext(False);
  1325. end;
  1326.  
  1327. constructor TChDirDialog.Load(var S: TStream);
  1328. var
  1329.   CurDir: DirStr;
  1330. begin
  1331.   TDialog.Load(S);
  1332.   GetSubViewPtr(S, DirList);
  1333.   GetSubViewPtr(S, DirInput);
  1334.   GetSubViewPtr(S, OkButton);
  1335.   GetSubViewPtr(S, ChDirbutton);
  1336.   SetUpDialog;
  1337. end;
  1338.  
  1339. function TChDirDialog.DataSize: Word;
  1340. begin
  1341.   DataSize := 0;
  1342. end;
  1343.  
  1344. procedure TChDirDialog.GetData(var Rec);
  1345. begin
  1346. end;
  1347.  
  1348. procedure TChDirDialog.HandleEvent(var Event: TEvent); 
  1349. var
  1350.   CurDir: DirStr;
  1351.   P: PDirEntry;
  1352. begin
  1353.   TDialog.HandleEvent(Event);
  1354.   case Event.What of
  1355.     evCommand:
  1356.       begin
  1357.         case Event.Command of
  1358.           cmRevert: GetDir(0,CurDir);
  1359.           cmChangeDir:
  1360.             begin
  1361.               P := DirList^.List^.At(DirList^.Focused);
  1362.               if (P^.Directory^ = Drives^) or DriveValid(P^.Directory^[1]) then
  1363.                 CurDir := P^.Directory^
  1364.               else Exit;
  1365.             end;
  1366.         else
  1367.           Exit;
  1368.         end;
  1369.         if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = '\') then
  1370.           CurDir := Copy(CurDir,1,Length(CurDir)-1);
  1371.         DirList^.NewDirectory(CurDir);
  1372.         DirInput^.Data^ := CurDir;
  1373.         DirInput^.DrawView;
  1374.         DirList^.Select;
  1375.         ClearEvent(Event);
  1376.       end;
  1377.   end;
  1378. end;
  1379.  
  1380. procedure TChDirDialog.SetData(var Rec);
  1381. begin
  1382. end;
  1383.  
  1384. procedure TChDirDialog.SetUpDialog;
  1385. var
  1386.   CurDir: DirStr;
  1387. begin
  1388.   if DirList <> nil then
  1389.   begin
  1390.     CurDir := GetCurDir;
  1391.     DirList^.NewDirectory(CurDir);
  1392.     if (Length(CurDir) > 3) and (CurDir[Length(CurDir)] = '\') then
  1393.       CurDir := Copy(CurDir,1,Length(CurDir)-1);
  1394.     if DirInput <> nil then
  1395.     begin
  1396.       DirInput^.Data^ := CurDir;
  1397.       DirInput^.DrawView;
  1398.     end;
  1399.   end;
  1400. end;
  1401.  
  1402. procedure TChDirDialog.Store(var S: TStream);
  1403. begin
  1404.   TDialog.Store(S);
  1405.   PutSubViewPtr(S, DirList);
  1406.   PutSubViewPtr(S, DirInput);
  1407.   PutSubViewPtr(S, OkButton);
  1408.   PutSubViewPtr(S, ChDirButton);
  1409. end;
  1410.  
  1411. function TChDirDialog.Valid(Command: Word): Boolean;
  1412. var
  1413.   P: PathStr;
  1414. begin
  1415.   Valid := True;
  1416.   if Command = cmOk then
  1417.   begin
  1418.     P := FExpand(DirInput^.Data^);
  1419.     if (Length(P) > 3) and (P[Length(P)] = '\') then Dec(P[0]);
  1420.     {$I-}
  1421.     ChDir(P);
  1422.     if IOResult <> 0 then
  1423.     begin
  1424.       MessageBox('Invalid directory.', nil, mfError + mfOkButton);
  1425.       Valid := False;
  1426.     end;
  1427.     {$I+}
  1428.   end;
  1429. end;
  1430.  
  1431. procedure RegisterStdDlg;
  1432. begin
  1433.   RegisterType(RFileInputLine);
  1434.   RegisterType(RFileCollection);
  1435.   RegisterType(RFileList);
  1436.   RegisterType(RFileInfoPane);
  1437.   RegisterType(RFileDialog);
  1438.   RegisterType(RDirCollection);
  1439.   RegisterType(RDirListBox);
  1440.   RegisterType(RChDirDialog);
  1441. end;
  1442.  
  1443. end.
  1444.