home *** CD-ROM | disk | FTP | other *** search
/ Delphi Anthology / aDELPHI.iso / Runimage / Delphi50 / Source / Samples / diroutln.pas < prev    next >
Pascal/Delphi Source File  |  1999-08-11  |  11KB  |  388 lines
  1. unit DirOutln;
  2.  
  3. { Directory outline component }
  4.  
  5. interface
  6.  
  7. uses Classes, Forms, Controls, Outline, SysUtils, Graphics, Grids, StdCtrls,
  8.      Menus;
  9.  
  10. type
  11.   TTextCase = (tcLowerCase, tcUpperCase, tcAsIs);
  12.   TCaseFunction = function(const AString: string): string;
  13.  
  14.   TDirectoryOutline = class(TCustomOutline)
  15.   private
  16.     FDrive: Char;
  17.     FDirectory: TFileName;
  18.     FOnChange: TNotifyEvent;
  19.     FTextCase: TTextCase;
  20.     FCaseFunction: TCaseFunction;
  21.   protected
  22.     procedure SetDrive(NewDrive: Char);
  23.     procedure SetDirectory(const NewDirectory: TFileName);
  24.     procedure SetTextCase(NewTextCase: TTextCase);
  25.     procedure AssignCaseProc;
  26.     procedure BuildOneLevel(RootItem: Longint); virtual;
  27.     procedure BuildTree; virtual;
  28.     procedure BuildSubTree(RootItem: Longint); virtual;
  29.     procedure Change; virtual;
  30.     procedure Click; override;
  31.     procedure CreateWnd; override;
  32.     procedure Expand(Index: Longint); override;
  33.     function FindIndex(RootNode: TOutLineNode; SearchName: TFileName): Longint;
  34.     procedure Loaded; override;
  35.     procedure WalkTree(const Dest: string);
  36.   public
  37.     constructor Create(AOwner: TComponent); override;
  38.     function ForceCase(const AString: string): string;
  39.     property Drive: Char  read FDrive write SetDrive;
  40.     property Directory: TFileName  read FDirectory write SetDirectory;
  41.     property Lines stored False;
  42.   published
  43.     property Align;
  44.     property Anchors;
  45.     property BorderStyle;
  46.     property Color;
  47.     property Constraints;
  48.     property Ctl3D;
  49.     property DragCursor;
  50.     property DragKind;
  51.     property DragMode;
  52.     property Enabled;
  53.     property Font;
  54.     property ItemHeight;
  55.     property Options default [ooStretchBitmaps, ooDrawFocusRect];
  56.     property ParentColor;
  57.     property ParentCtl3D;
  58.     property ParentFont;
  59.     property ParentShowHint;
  60.     property PictureClosed;
  61.     property PictureLeaf;
  62.     property PictureOpen;
  63.     property PopupMenu;
  64.     property ScrollBars;
  65.     property Style;
  66.     property ShowHint;
  67.     property TabOrder;
  68.     property TabStop;
  69.     property TextCase: TTextCase  read FTextCase write SetTextCase default tcLowerCase;
  70.     property Visible;
  71.     property OnChange: TNotifyEvent  read FOnChange write FOnChange;
  72.     property OnClick;
  73.     property OnCollapse;
  74.     property OnDblClick;
  75.     property OnDragDrop;
  76.     property OnDragOver;
  77.     property OnDrawItem;
  78.     property OnEndDock;
  79.     property OnEndDrag;
  80.     property OnEnter;
  81.     property OnExit;
  82.     property OnExpand;
  83.     property OnKeyDown;
  84.     property OnKeyPress;
  85.     property OnKeyUp;
  86.     property OnMouseDown;
  87.     property OnMouseMove;
  88.     property OnMouseUp;
  89.     property OnStartDock;
  90.     property OnStartDrag;
  91.   end;
  92.  
  93. function SameLetter(Letter1, Letter2: Char): Boolean;
  94.  
  95.  
  96. implementation
  97.  
  98. const
  99.   InvalidIndex = -1;
  100.  
  101. constructor TDirectoryOutline.Create(AOwner: TComponent);
  102. begin
  103.   inherited Create(AOwner);
  104.   PictureLeaf := PictureClosed;
  105.   Options := [ooDrawFocusRect];
  106.   TextCase := tcLowerCase;
  107.   AssignCaseProc;
  108. end;
  109.  
  110. procedure TDirectoryOutline.AssignCaseProc;
  111. begin
  112.   case TextCase of
  113.     tcLowerCase: FCaseFunction := AnsiLowerCaseFileName;
  114.     tcUpperCase: FCaseFunction := AnsiUpperCaseFileName;
  115.     else FCaseFunction := nil;
  116.   end;
  117. end;
  118.  
  119. type
  120.   PNodeInfo = ^TNodeInfo;
  121.   TNodeInfo = record
  122.     RootName: TFileName;
  123.     SearchRec: TSearchRec;
  124.     DosError: Integer;
  125.     RootNode: TOutlineNode;
  126.     TempChild, NewChild: Longint;
  127.   end;
  128.  
  129. function TDirectoryOutline.FindIndex(RootNode: TOutLineNode;
  130.   SearchName: TFileName): Longint;
  131. var
  132.   FirstChild, LastChild, TempChild: Longint;
  133. begin
  134.   FirstChild := RootNode.GetFirstChild;
  135.   if (FirstChild = InvalidIndex) or
  136.      (SearchName <= Items[FirstChild].Text) then
  137.        FindIndex := FirstChild
  138.   else
  139.   begin
  140.     LastChild := RootNode.GetLastChild;
  141.     if (SearchName >= Items[LastChild].Text) then
  142.       FindIndex := InvalidIndex
  143.     else
  144.     begin
  145.       repeat
  146.         TempChild := (FirstChild + LastChild) div 2; { binary search }
  147.         if (TempChild = FirstChild) then Inc(TempChild);
  148.         if (SearchName > Items[TempChild].Text) then
  149.           FirstChild := TempChild
  150.         else LastChild := TempChild
  151.       until FirstChild >= (LastChild - 1);
  152.       FindIndex := LastChild
  153.     end
  154.   end
  155. end;
  156.  
  157. procedure TDirectoryOutline.BuildOneLevel(RootItem: Longint);
  158. var
  159.   NodeInfo: PNodeInfo;
  160.   P: Integer;
  161. begin
  162.   New(NodeInfo);
  163.   try
  164.     with NodeInfo^ do
  165.     begin
  166.       RootName := Items[RootItem].FullPath;
  167.       P := AnsiPos(':\\', RootName);
  168.       if P <> 0 then System.Delete(RootName, P + 2, 1);
  169.       if (RootName <> '') and (AnsiLastChar(RootName) <> '\') then
  170.         RootName := Concat(RootName, '\');
  171.       RootName := Concat(RootName, '*.*');
  172.       DosError := FindFirst(RootName, faDirectory, SearchRec);
  173.       try
  174.         while DosError = 0 do
  175.         begin
  176.           if (SearchRec.Attr and faDirectory = faDirectory) and (SearchRec.Name[1] <> '.') then
  177.           begin
  178.             SearchRec.Name := ForceCase(SearchRec.Name);
  179.             RootNode := Items[RootItem];
  180.             if RootNode.HasItems then { if has children, must alphabetize }
  181.             begin
  182.               TempChild := FindIndex(RootNode, SearchRec.Name);
  183.               if TempChild <> InvalidIndex then
  184.                 NewChild := Insert(TempChild, SearchRec.Name)
  185.               else NewChild := Add(RootNode.GetLastChild, SearchRec.Name);
  186.             end
  187.             else NewChild := AddChild(RootItem, SearchRec.Name); { if first child, just add }
  188.           end;
  189.           DosError := FindNext(SearchRec);
  190.         end;
  191.       finally
  192.         FindClose(SearchRec);
  193.       end;
  194.     end;
  195.     Items[RootItem].Data := Pointer(1); { make non-nil so we know we've been here }
  196.   finally
  197.     Dispose(NodeInfo);
  198.   end;
  199. end;
  200.  
  201. procedure TDirectoryOutline.BuildTree;
  202. begin
  203.   Clear;
  204.   AddChild(0, ForceCase(Drive + ':\'));
  205.   WalkTree(FDirectory);
  206.   Change;
  207. end;
  208.  
  209. procedure TDirectoryOutline.BuildSubTree(RootItem: Longint);
  210. var
  211.   TempRoot: Longint;
  212.   RootNode: TOutlineNode;
  213. begin
  214.   BuildOneLevel(RootItem);
  215.   RootNode := Items[RootItem];
  216.   TempRoot := RootNode.GetFirstChild;
  217.   while TempRoot <> InvalidIndex do
  218.   begin
  219.     BuildSubTree(TempRoot);
  220.     TempRoot := RootNode.GetNextChild(TempRoot);
  221.   end;
  222. end;
  223.  
  224. procedure TDirectoryOutline.Change;
  225. begin
  226.   if Assigned(FOnChange) then FOnChange(Self);
  227. end;
  228.  
  229. procedure TDirectoryOutline.Click;
  230. var
  231.   P: Integer;
  232.   S: string;
  233. begin
  234.   inherited Click;
  235.   S := Items[SelectedItem].FullPath;
  236.   P := AnsiPos(':\\', S);
  237.   if P <> 0 then System.Delete(S, P + 2, 1);
  238.   Directory := S;
  239. end;
  240.  
  241. procedure TDirectoryOutline.CreateWnd;
  242. var
  243.   CurrentPath: string;
  244. begin
  245.   inherited CreateWnd;
  246.   if FDrive = #0 then
  247.   begin
  248.     GetDir(0, CurrentPath);
  249.     FDrive := ForceCase(CurrentPath)[1];
  250.     FDirectory := ForceCase(CurrentPath);
  251.   end;
  252.   if (not (csLoading in ComponentState)) and
  253.     (csDesigning in ComponentState) then BuildTree;
  254. end;
  255.  
  256. procedure TDirectoryOutline.Expand(Index: Longint);
  257. begin
  258.   if Items[Index].Data = nil then { if we've not previously expanded }
  259.     BuildOneLevel(Index);
  260.   inherited Expand(Index); { call the event handler }
  261. end;
  262.  
  263. function TDirectoryOutline.ForceCase(const AString: string): string;
  264. begin
  265.   if Assigned(FCaseFunction) then
  266.     Result := FCaseFunction(AString)
  267.   else Result := AString;
  268. end;
  269.  
  270. procedure TDirectoryOutline.Loaded;
  271. begin
  272.   inherited Loaded;
  273.   AssignCaseProc;
  274.   BuildTree;
  275. end;
  276.  
  277. procedure TDirectoryOutline.SetDirectory(const NewDirectory: TFileName);
  278. var
  279.   TempPath: TFileName;
  280. begin
  281.   if Length(NewDirectory) > 0 then  { ignore empty directory }
  282.   begin
  283.     if Copy(NewDirectory, Length(NewDirectory) - 1, 2) = ':\' then
  284.       TempPath := ForceCase(NewDirectory)
  285.     else
  286.       TempPath := ForceCase(ExpandFileName(NewDirectory)); { expand to full path }
  287.     if (Length(TempPath) > 3) and (AnsiLastChar(TempPath) = '\') then
  288.       SetLength(TempPath, Length(TempPath) - 1);
  289.     if AnsiCompareFileName(TempPath, FDirectory) <> 0 then { is it a dir change? }
  290.     begin
  291.       FDirectory := TempPath; { set new directory }
  292.       ChDir(FDirectory); { go there }
  293.       if TempPath[1] <> Drive then { check to see if we changed drives, too }
  294.         Drive := TempPath[1] { change drive/build list if needed }
  295.       else
  296.       begin
  297.         if Copy(FDirectory, Length(FDirectory) - 1, 2) = ':\' then
  298.           WalkTree(TempPath);
  299.         Change; { otherwise, we're done }
  300.       end;
  301.     end;
  302.   end;
  303. end;
  304.  
  305. procedure TDirectoryOutline.SetDrive(NewDrive: Char);
  306. var
  307.   TempPath: string;
  308. begin
  309.   if UpCase(NewDrive) in ['A'..'Z'] then { disallow all but drive letters}
  310.   begin
  311.     if (FDrive = #0) or not SameLetter(NewDrive, FDrive) then { update if no current drive or change }
  312.     begin
  313.       FDrive := NewDrive;
  314.       ChDir(FDrive + ':\');
  315.       GetDir(0, TempPath);
  316.       FDirectory := ForceCase(TempPath); { use correct case }
  317.       if not (csLoading in ComponentState) then BuildTree; { this ends up calling Change }
  318.     end;
  319.   end;
  320. end;
  321.  
  322. procedure TDirectoryOutline.SetTextCase(NewTextCase: TTextCase);
  323. var
  324.   CurrentPath: string;
  325. begin
  326.   if NewTextCase <> FTextCase then
  327.   begin
  328.     FTextCase := NewTextCase;
  329.     AssignCaseProc;
  330.     if NewTextCase = tcAsIs then
  331.     begin
  332.       GetDir(0, CurrentPath);
  333.       FDrive := CurrentPath[1];
  334.       FDirectory := CurrentPath;
  335.     end;
  336.     if not (csLoading in ComponentState) then BuildTree;
  337.   end;
  338. end;
  339.  
  340. procedure TDirectoryOutline.WalkTree(const Dest: string);
  341. var
  342.   TempPath, NextDir: TFileName;
  343.   SlashPos: Integer;
  344.   TempItem: Longint;
  345.  
  346.   function GetChildNamed(const Name: string): Longint;
  347.   begin
  348.     Items[TempItem].Expanded := True;
  349.     Result := Items[TempItem].GetFirstChild;
  350.     while Result <> InvalidIndex do
  351.     begin
  352.       if Items[Result].Text = Name then Exit;
  353.       Result := Items[TempItem].GetNextChild(Result);
  354.     end;
  355.   end;
  356.  
  357. begin
  358.   TempItem := 1; { start at root }
  359.   TempPath := ForceCase(Dest);
  360.   if Pos(':', TempPath) > 0 then
  361.     TempPath := Copy(TempPath, Pos(':', TempPath) + 1, Length(TempPath));
  362.   if TempPath[1] = '\' then System.Delete(TempPath, 1, 1);
  363.   NextDir := TempPath;
  364.   while Length(TempPath) > 0 do
  365.   begin
  366.     SlashPos := AnsiPos('\', TempPath);
  367.     if SlashPos > 0 then
  368.     begin
  369.       NextDir := Copy(TempPath, 1, SlashPos - 1);
  370.       TempPath := Copy(TempPath, SlashPos + 1, Length(TempPath));
  371.     end
  372.     else
  373.     begin
  374.       NextDir := TempPath;
  375.       TempPath := '';
  376.     end;
  377.     TempItem := GetChildNamed(NextDir);
  378.   end;
  379.   SelectedItem := TempItem;
  380. end;
  381.  
  382. function SameLetter(Letter1, Letter2: Char): Boolean;
  383. begin
  384.   Result := UpCase(Letter1) = UpCase(Letter2);
  385. end;
  386.  
  387. end.
  388.