1 {
2 /***************************************************************************
3 ShellCtrls.pas
4 ------------
5
6
7 ***************************************************************************/
8
9 *****************************************************************************
10 This file is part of the Lazarus Component Library (LCL)
11
12 See the file COPYING.modifiedLGPL.txt, included in this distribution,
13 for details about the license.
14 *****************************************************************************
15 }
16 unit ShellCtrls;
17
18 {$mode objfpc}{$H+}
19
20 {.$define debug_shellctrls}
21
22 interface
23
24 uses
25 Classes, SysUtils, Laz_AVL_Tree,
26 // LCL
27 Forms, Graphics, ComCtrls, LCLProc, LCLStrConsts,
28 // LazUtils
29 FileUtil, LazFileUtils, LazUTF8;
30
31 {$if defined(Windows) or defined(darwin) or defined(HASAMIGA))}
32 {$define CaseInsensitiveFilenames}
33 {$endif}
34 {$IF defined(CaseInsensitiveFilenames) or defined(darwin)}
35 {$DEFINE NotLiteralFilenames}
36 {$ENDIF}
37
38 type
39
40 { TObjectTypes }
41
42 TObjectType = (otFolders, otNonFolders, otHidden);
43
44 TObjectTypes = set of TObjectType;
45
46 TFileSortType = (fstNone, fstAlphabet, fstFoldersFirst);
47
48 { Forward declaration of the classes }
49
50 TCustomShellTreeView = class;
51 TCustomShellListView = class;
52
53 { TCustomShellTreeView }
54
55 TCustomShellTreeView = class(TCustomTreeView)
56 private
57 FObjectTypes: TObjectTypes;
58 FRoot: string;
59 FShellListView: TCustomShellListView;
60 FFileSortType: TFileSortType;
61 FInitialRoot: String;
62 { Setters and getters }
GetPathnull63 function GetPath: string;
64 procedure SetFileSortType(const AValue: TFileSortType);
65 procedure SetObjectTypes(AValue: TObjectTypes);
66 procedure SetPath(AValue: string);
67 procedure SetRoot(const AValue: string);
68 procedure SetShellListView(const Value: TCustomShellListView);
69 protected
70 procedure DoCreateNodeClass(var NewNodeClass: TTreeNodeClass); override;
71 procedure Loaded; override;
CreateNodenull72 function CreateNode: TTreeNode; override;
73 { Other methods specific to Lazarus }
PopulateTreeNodeWithFilesnull74 function PopulateTreeNodeWithFiles(
75 ANode: TTreeNode; ANodePath: string): Boolean;
76 procedure DoSelectionChanged; override;
CanExpandnull77 function CanExpand(Node: TTreeNode): Boolean; override;
78 public
79 { Basic methods }
80 constructor Create(AOwner: TComponent); override;
81 destructor Destroy; override;
82
83 { Methods specific to Lazarus - useful for other classes }
GetBasePathnull84 class function GetBasePath: string;
GetRootPathnull85 function GetRootPath: string;
86 class procedure GetFilesInDir(const ABaseDir: string;
87 AMask: string; AObjectTypes: TObjectTypes; AResult: TStrings; AFileSortType: TFileSortType = fstNone);
88 { Other methods specific to Lazarus }
GetPathFromNodenull89 function GetPathFromNode(ANode: TTreeNode): string;
90 procedure PopulateWithBaseFiles;
91 procedure Refresh(ANode: TTreeNode); overload;
92
93 { Properties }
94 property ObjectTypes: TObjectTypes read FObjectTypes write SetObjectTypes;
95 property ShellListView: TCustomShellListView read FShellListView write SetShellListView;
96 property FileSortType: TFileSortType read FFileSortType write SetFileSortType;
97 property Root: string read FRoot write SetRoot;
98 property Path: string read GetPath write SetPath;
99
100 { Protected properties which users may want to access, see bug 15374 }
101 property Items;
102 end;
103
104 { TShellTreeView }
105
106 TShellTreeView = class(TCustomShellTreeView)
107 published
108 { TCustomTreeView properties }
109 property Align;
110 property Anchors;
111 property AutoExpand;
112 property BorderSpacing;
113 //property BiDiMode;
114 property BackgroundColor;
115 property BorderStyle;
116 property BorderWidth;
117 property Color;
118 property Constraints;
119 property Enabled;
120 property ExpandSignType;
121 property Font;
122 property FileSortType;
123 property HideSelection;
124 property HotTrack;
125 property Images;
126 property Indent;
127 //property ParentBiDiMode;
128 property ParentColor default False;
129 property ParentFont;
130 property ParentShowHint;
131 property PopupMenu;
132 property ReadOnly;
133 property RightClickSelect;
134 property Root;
135 property RowSelect;
136 property ScrollBars;
137 property SelectionColor;
138 property ShowButtons;
139 property ShowHint;
140 property ShowLines;
141 property ShowRoot;
142 property StateImages;
143 property TabOrder;
144 property TabStop default True;
145 property Tag;
146 property ToolTips;
147 property Visible;
148 property OnAdvancedCustomDraw;
149 property OnAdvancedCustomDrawItem;
150 property OnChange;
151 property OnChanging;
152 property OnClick;
153 property OnCollapsed;
154 property OnCollapsing;
155 property OnCustomDraw;
156 property OnCustomDrawItem;
157 property OnDblClick;
158 property OnEdited;
159 property OnEditing;
160 property OnEnter;
161 property OnExit;
162 property OnExpanded;
163 property OnExpanding;
164 property OnGetImageIndex;
165 property OnGetSelectedIndex;
166 property OnKeyDown;
167 property OnKeyPress;
168 property OnKeyUp;
169 property OnMouseDown;
170 property OnMouseEnter;
171 property OnMouseLeave;
172 property OnMouseMove;
173 property OnMouseUp;
174 property OnMouseWheel;
175 property OnMouseWheelDown;
176 property OnMouseWheelUp;
177 property OnSelectionChanged;
178 property OnShowHint;
179 property OnUTF8KeyPress;
180 property Options;
181 property TreeLineColor;
182 property TreeLinePenStyle;
183 property ExpandSignColor;
184 { TCustomShellTreeView properties }
185 property ObjectTypes;
186 property ShellListView;
187 end;
188
189 { TCustomShellListView }
190
191 TCSLVFileAddedEvent = procedure(Sender: TObject; Item: TListItem) of object;
192
193 TCustomShellListView = class(TCustomListView)
194 private
195 FMask: string;
196 FObjectTypes: TObjectTypes;
197 FRoot: string;
198 FShellTreeView: TCustomShellTreeView;
199 FOnFileAdded: TCSLVFileAddedEvent;
200 { Setters and getters }
201 procedure SetMask(const AValue: string);
202 procedure SetShellTreeView(const Value: TCustomShellTreeView);
203 procedure SetRoot(const Value: string);
204 protected
205 { Methods specific to Lazarus }
206 procedure PopulateWithRoot();
207 procedure Resize; override;
208 property OnFileAdded: TCSLVFileAddedEvent read FOnFileAdded write FOnFileAdded;
209 public
210 { Basic methods }
211 constructor Create(AOwner: TComponent); override;
212 destructor Destroy; override;
213 { Methods specific to Lazarus }
GetPathFromItemnull214 function GetPathFromItem(ANode: TListItem): string;
215 { Properties }
216 property Mask: string read FMask write SetMask; // Can be used to conect to other controls
217 property ObjectTypes: TObjectTypes read FObjectTypes write FObjectTypes;
218 property Root: string read FRoot write SetRoot;
219 property ShellTreeView: TCustomShellTreeView read FShellTreeView write SetShellTreeView;
220 { Protected properties which users may want to access, see bug 15374 }
221 property Items;
222 end;
223
224 { TShellListView }
225
226 TShellListView = class(TCustomShellListView)
227 public
228 property Columns;
229 published
230 { TCustomListView properties
231 The same as TListView excluding data properties }
232 property Align;
233 property Anchors;
234 property BorderSpacing;
235 property BorderStyle;
236 property BorderWidth;
237 // property Checkboxes;
238 property Color default clWindow;
239 // property ColumnClick;
240 property Constraints;
241 property DragCursor;
242 property DragMode;
243 // property DefaultItemHeight;
244 // property DropTarget;
245 property Enabled;
246 // property FlatScrollBars;
247 property Font;
248 // property FullDrag;
249 // property GridLines;
250 property HideSelection;
251 // property HotTrack;
252 // property HotTrackStyles;
253 // property HoverTime;
254 property LargeImages;
255 property Mask;
256 property MultiSelect;
257 // property OwnerData;
258 // property OwnerDraw;
259 property ParentColor default False;
260 property ParentFont;
261 property ParentShowHint;
262 property PopupMenu;
263 property ReadOnly;
264 property RowSelect;
265 property ScrollBars;
266 property ShowColumnHeaders;
267 property ShowHint;
268 // property ShowWorkAreas;
269 property SmallImages;
270 property SortColumn;
271 property SortType;
272 property StateImages;
273 property TabStop;
274 property TabOrder;
275 property ToolTips;
276 property Visible;
277 property ViewStyle default vsReport;
278 // property OnAdvancedCustomDraw;
279 // property OnAdvancedCustomDrawItem;
280 // property OnAdvancedCustomDrawSubItem;
281 property OnChange;
282 property OnClick;
283 property OnColumnClick;
284 property OnCompare;
285 property OnContextPopup;
286 // property OnCustomDraw;
287 // property OnCustomDrawItem;
288 // property OnCustomDrawSubItem;
289 property OnDblClick;
290 property OnDeletion;
291 property OnDragDrop;
292 property OnDragOver;
293 property OnEndDrag;
294 property OnKeyDown;
295 property OnKeyPress;
296 property OnKeyUp;
297 property OnMouseDown;
298 property OnMouseEnter;
299 property OnMouseLeave;
300 property OnMouseMove;
301 property OnMouseUp;
302 property OnMouseWheel;
303 property OnMouseWheelDown;
304 property OnMouseWheelUp;
305 property OnResize;
306 property OnSelectItem;
307 property OnStartDrag;
308 property OnUTF8KeyPress;
309 property OnFileAdded;
310 { TCustomShellListView properties }
311 property ObjectTypes;
312 property Root;
313 property ShellTreeView;
314 end;
315
316 { TShellTreeNode }
317
318 TShellTreeNode = class(TTreeNode)
319 private
320 FFileInfo: TSearchRec;
321 FBasePath: String;
322 protected
323 procedure SetBasePath(ABasePath: String);
324 public
ShortFilenamenull325 function ShortFilename: String;
FullFilenamenull326 function FullFilename: String;
IsDirectorynull327 function IsDirectory: Boolean;
328
329 property BasePath: String read FBasePath;
330 end;
331
332 EShellCtrl = class(Exception);
333 EInvalidPath = class(EShellCtrl);
334
DbgSnull335 function DbgS(OT: TObjectTypes): String; overload;
336
337 procedure Register;
338
339 implementation
340
341 {$ifdef windows}
342 uses Windows;
343 {$endif}
344
345 const
346 //no need to localize, it's a message for the programmer
347 sShellTreeViewIncorrectNodeType = 'TShellTreeView: the newly created node is not a TShellTreeNode!';
348
349 function DbgS(OT: TObjectTypes): String; overload;
350 begin
351 Result := '[';
352 if (otFolders in OT) then Result := Result + 'otFolders,';
353 if (otNonFolders in OT) then Result := Result + 'otNonFolders,';
354 if (otHidden in OT) then Result := Result + 'otHidden';
355 if Result[Length(Result)] = ',' then System.Delete(Result, Length(Result), 1);
356 Result := Result + ']';
357 end;
358
359 { TFileItem : internal helper class used for temporarily storing info in an internal TStrings component}
360 type
361 { TFileItem }
362 TFileItem = class(TObject)
363 private
364 FFileInfo: TSearchRec;
365 FBasePath: String;
366 public
367 //more data to sort by size, date... etc
368 isFolder: Boolean;
369 constructor Create(const DirInfo: TSearchRec; ABasePath: String);
370 property FileInfo: TSearchRec read FFileInfo write FFileInfo;
371 end;
372
373
374 constructor TFileItem.Create(const DirInfo:TSearchRec; ABasePath: String);
375 begin
376 FFileInfo := DirInfo;
377 FBasePath:= ABasePath;
378 isFolder:=DirInfo.Attr and FaDirectory > 0;
379 end;
380
381
382
383 { TShellTreeNode }
384
385 procedure TShellTreeNode.SetBasePath(ABasePath: String);
386 begin
387 FBasePath := ABasePath;
388 end;
389
390
ShortFilenamenull391 function TShellTreeNode.ShortFilename: String;
392 begin
393 Result := ExtractFileName(FFileInfo.Name);
394 if (Result = '') then Result := FFileInfo.Name;
395 end;
396
FullFilenamenull397 function TShellTreeNode.FullFilename: String;
398 begin
399 if (FBasePath <> '') then
400 Result := AppendPathDelim(FBasePath) + FFileInfo.Name
401 else
402 //root nodes
403 Result := FFileInfo.Name;
404 {$if defined(windows) and not defined(wince)}
405 if (Length(Result) = 2) and (Result[2] = DriveSeparator) then
406 Result := Result + PathDelim;
407 {$endif}
408 end;
409
IsDirectorynull410 function TShellTreeNode.IsDirectory: Boolean;
411 begin
412 Result := ((FFileInfo.Attr and faDirectory) > 0);
413 end;
414
415
416 { TCustomShellTreeView }
417
418 procedure TCustomShellTreeView.SetShellListView(
419 const Value: TCustomShellListView);
420 var
421 Tmp: TCustomShellListView;
422 begin
423 if FShellListView = Value then Exit;
424
425 if Assigned(FShellListView) then
426 begin
427 Tmp := FShellListView;
428 FShellListView := nil;
429 Tmp.ShellTreeView := nil;
430 end;
431
432 FShellListView := Value;
433
434 // Update the pair, it will then update itself
435 // in the setter of this property
436 // Updates only if necessary to avoid circular calls of the setters
437 if Assigned(Value) and (Value.ShellTreeView <> Self) then
438 Value.ShellTreeView := Self;
439 end;
440
441
442 procedure TCustomShellTreeView.DoCreateNodeClass(
443 var NewNodeClass: TTreeNodeClass);
444 begin
445 NewNodeClass := TShellTreeNode;
446 inherited DoCreateNodeClass(NewNodeClass);
447 end;
448
449 procedure TCustomShellTreeView.Loaded;
450 begin
451 inherited Loaded;
452 if (FInitialRoot = '') then
453 PopulateWithBaseFiles()
454 else
455 SetRoot(FInitialRoot);
456 end;
457
CreateNodenull458 function TCustomShellTreeView.CreateNode: TTreeNode;
459 begin
460 Result := inherited CreateNode;
461 //just in case someone attaches a new OnCreateNodeClass which does not return a TShellTreeNode (sub)class
462 if not (Result is TShellTreeNode) then
463 Raise EShellCtrl.Create(sShellTreeViewIncorrectNodeType);
464 end;
465
466 procedure TCustomShellTreeView.SetRoot(const AValue: string);
467 var
468 RootNode: TTreeNode;
469 begin
470 if FRoot=AValue then exit;
471 if (csLoading in ComponentState) then
472 begin
473 FInitialRoot := AValue;
474 Exit;
475 end;
476 //Delphi raises an exception in this case, but don't crash the IDE at designtime
477 if not (csDesigning in ComponentState)
478 and (AValue <> '')
479 and not DirectoryExistsUtf8(ExpandFilenameUtf8(AValue)) then
480 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidRoot,[ExpandFileNameUtf8(AValue)]);
481 if (AValue = '') then
482 FRoot := GetBasePath
483 else
484 FRoot:=AValue;
485 Items.Clear;
486 if FRoot = '' then
487 begin
488 PopulateWithBaseFiles()
489 end
490 else
491 begin
492 //Add a node for Root and expand it (issue #0024230)
493 //Make FRoot contain fully qualified pathname, we need it later in GetPathFromNode()
494 FRoot := ExpandFileNameUtf8(FRoot);
495 //Set RootNode.Text to AValue so user can choose if text is fully qualified path or not
496 RootNode := Items.AddChild(nil, AValue);
497 TShellTreeNode(RootNode).FFileInfo.Attr := FileGetAttr(FRoot);
498 TShellTreeNode(RootNode).FFileInfo.Name := FRoot;
499 TShellTreeNode(RootNode).SetBasePath('');
500 RootNode.HasChildren := True;
501 RootNode.Expand(False);
502 end;
503 if Assigned(ShellListView) then
504 ShellListView.Root := FRoot;
505 end;
506
507 // ToDo: Optimize, now the tree is populated in constructor, SetRoot and SetFileSortType.
508 // For some reason it does not show in performance really.
509 procedure TCustomShellTreeView.SetFileSortType(const AValue: TFileSortType);
510 var
511 RootNode: TTreeNode;
512 CurrPath: String;
513 begin
514 if FFileSortType=AValue then exit;
515 FFileSortType:=AValue;
516 if (([csLoading,csDesigning] * ComponentState) <> []) then Exit;
517 CurrPath := GetPath;
518 try
519 BeginUpdate;
520 Items.Clear;
521 if FRoot = '' then
522 PopulateWithBaseFiles()
523 else
524 begin
525 RootNode := Items.AddChild(nil, FRoot);
526 RootNode.HasChildren := True;
527 RootNode.Expand(False);
528 try
529 SetPath(CurrPath);
530 except
531 // CurrPath may have been removed in the mean time by another process, just ignore
532 on E: EInvalidPath do ;//
533 end;
534 end;
535 finally
536 EndUpdate;
537 end;
538 end;
539
540 procedure TCustomShellTreeView.SetObjectTypes(AValue: TObjectTypes);
541 var
542 CurrPath: String;
543 begin
544 if FObjectTypes = AValue then Exit;
545 FObjectTypes := AValue;
546 if (csLoading in ComponentState) then Exit;
547 CurrPath := GetPath;
548 try
549 BeginUpdate;
550 Refresh(nil);
551 try
552 SetPath(CurrPath);
553 except
554 // CurrPath may have been removed in the mean time by another process, just ignore
555 on E: EInvalidPath do ;//
556 end;
557 finally
558 EndUpdate;
559 end;
560 end;
561
TCustomShellTreeView.CanExpandnull562 function TCustomShellTreeView.CanExpand(Node: TTreeNode): Boolean;
563 var
564 OldAutoExpand: Boolean;
565 begin
566 Result:=inherited CanExpand(Node);
567 if not Result then exit;
568 OldAutoExpand:=AutoExpand;
569 AutoExpand:=False;
570 Node.DeleteChildren;
571 Result := PopulateTreeNodeWithFiles(Node, GetPathFromNode(Node));
572 AutoExpand:=OldAutoExpand;
573 end;
574
575 constructor TCustomShellTreeView.Create(AOwner: TComponent);
576 begin
577 inherited Create(AOwner);
578 FInitialRoot := '';
579
580 // Initial property values
581 FObjectTypes:= [otFolders];
582
583 // Populating the base dirs is done in Loaded
584 end;
585
586 destructor TCustomShellTreeView.Destroy;
587 begin
588 ShellListView := nil;
589 inherited Destroy;
590 end;
591
592
FilesSortAlphabetnull593 function FilesSortAlphabet(p1, p2: Pointer): Integer;
594 var
595 f1, f2: TFileItem;
596 begin
597 f1:=TFileItem(p1);
598 f2:=TFileItem(p2);
599 Result:=CompareText(f1.FileInfo.Name, f2.FileInfo.Name);
600 end;
601
FilesSortFoldersFirstnull602 function FilesSortFoldersFirst(p1,p2: Pointer): Integer;
603 var
604 f1, f2: TFileItem;
605 begin
606 f1:=TFileItem(p1);
607 f2:=TFileItem(p2);
608 if f1.isFolder=f2.isFolder then
609 Result:=FilesSortAlphabet(p1,p2)
610 else begin
611 if f1.isFolder then Result:=-1
612 else Result:=1;
613 end;
614
615 end;
616
STVCompareFilesnull617 function STVCompareFiles(f1, f2: Pointer): integer;
618 begin
619 Result:=CompareFilenames(AnsiString(f1),AnsiString(f2));
620 end;
621
622 { Helper routine.
623 Finds all files/directories directly inside a directory.
624 Does not recurse inside subdirectories.
625
626 AResult will contain TFileItem objects upon return, make sure to free them in the calling routine
627
628 AMask may contain multiple file masks separated by ;
629 Don't add a final ; after the last mask.
630 }
631 class procedure TCustomShellTreeView.GetFilesInDir(const ABaseDir: string;
632 AMask: string; AObjectTypes: TObjectTypes; AResult: TStrings; AFileSortType: TFileSortType);
633 var
634 DirInfo: TSearchRec;
635 FindResult: Integer;
636 IsDirectory, IsValidDirectory, IsHidden, AddFile: Boolean;
637 SearchStr: string;
638 MaskStr: string;
639 Files: TList;
640 FileItem: TFileItem;
641 i: Integer;
642 MaskStrings: TStringList;
643 FileTree: TAvlTree;
644 ShortFilename: AnsiString;
645 j: Integer;
646 {$if defined(windows) and not defined(wince)}
647 ErrMode : LongWord;
648 {$endif}
649 begin
650 {$if defined(windows) and not defined(wince)}
651 // disables the error dialog, while enumerating not-available drives
652 // for example listing A: path, without diskette present.
653 // WARNING: Since Application.ProcessMessages is called, it might effect some operations!
654 ErrMode:=SetErrorMode(SEM_FAILCRITICALERRORS or SEM_NOALIGNMENTFAULTEXCEPT or SEM_NOGPFAULTERRORBOX or SEM_NOOPENFILEERRORBOX);
655 try
656 {$endif}
657
658 if Trim(AMask) = '' then MaskStr := AllFilesMask
659 else MaskStr := AMask;
660
661 // The string list implements support for multiple masks separated
662 // by semi-colon ";"
663 MaskStrings := TStringList.Create;
664 FileTree:=TAvlTree.Create(@STVCompareFiles);
665 try
666 {$ifdef NotLiteralFilenames}
667 MaskStrings.CaseSensitive := False;
668 {$else}
669 MaskStrings.CaseSensitive := True;
670 {$endif}
671
672 MaskStrings.Delimiter := ';';
673 MaskStrings.DelimitedText := MaskStr;
674
675 if AFileSortType=fstNone then Files:=nil
676 else Files:=TList.Create;
677
678 j:=0;
679 for i := 0 to MaskStrings.Count - 1 do
680 begin
681 if MaskStrings.IndexOf(MaskStrings[i]) < i then Continue; // From patch from bug 17761: TShellListView Mask: duplicated items if mask is " *.ext;*.ext "
682 SearchStr := IncludeTrailingPathDelimiter(ABaseDir) + MaskStrings.Strings[i];
683
684 FindResult := FindFirstUTF8(SearchStr, faAnyFile, DirInfo);
685
686 while FindResult = 0 do
687 begin
688 inc(j);
689 if j=100 then
690 begin
691 Application.ProcessMessages;
692 j:=0;
693 end;
694
695 ShortFilename := DirInfo.Name;
696
697 IsDirectory := (DirInfo.Attr and FaDirectory = FaDirectory);
698
699 IsValidDirectory := (ShortFilename <> '.') and (ShortFilename <> '..');
700
701 IsHidden := (DirInfo.Attr and faHidden{%H-} = faHidden{%H-});
702
703 // First check if we show hidden files
704 if IsHidden then AddFile := (otHidden in AObjectTypes)
705 else AddFile := True;
706
707 // If it is a directory, check if it is a valid one
708 if IsDirectory then
709 AddFile := AddFile and ((otFolders in AObjectTypes) and IsValidDirectory)
710 else
711 AddFile := AddFile and (otNonFolders in AObjectTypes);
712
713 // AddFile identifies if the file is valid or not
714 if AddFile then
715 begin
716 if not Assigned(Files) then begin
717 if FileTree.Find(Pointer(ShortFilename))=nil then
718 begin
719 // From patch from bug 17761: TShellListView Mask: duplicated items if mask is " *.ext;*.ext "
720 FileTree.Add(Pointer(ShortFilename));
721 AResult.AddObject(ShortFilename, TFileItem.Create(DirInfo, ABaseDir));
722 end;
723 end else
724 Files.Add ( TFileItem.Create(DirInfo, ABaseDir));
725 end;
726
727 FindResult := FindNextUTF8(DirInfo);
728 end;
729
730 FindCloseUTF8(DirInfo);
731 end;
732 finally
733 FileTree.Free;
734 MaskStrings.Free;
735 end;
736
737 if Assigned(Files) then begin
738
739 case AFileSortType of
740 fstAlphabet: Files.Sort(@FilesSortAlphabet);
741 fstFoldersFirst: Files.Sort(@FilesSortFoldersFirst);
742 end;
743
744 for i:=0 to Files.Count-1 do
745 begin
746 FileItem:=TFileItem(Files[i]);
747 if (i < Files.Count - 1) and (TFileItem(Files[i]).FileInfo.Name = TFileItem(Files[i + 1]).FileInfo.Name) then
748 begin
749 FileItem.Free;
750 Continue; // cause Files is sorted // From patch from bug 17761: TShellListView Mask: duplicated items if mask is " *.ext;*.ext "
751 end;
752 AResult.AddObject(FileItem.FileInfo.Name, FileItem);
753 end;
754 //don't free the TFileItems here, they will freed by the calling routine
755 Files.Free;
756 end;
757
758 {$if defined(windows) and not defined(wince)}
759 finally
760 SetErrorMode(ErrMode);
761 end;
762 {$endif}
763 end;
764
765 class function TCustomShellTreeView.GetBasePath: string;
766 begin
767 {$if defined(windows) and not defined(wince)}
768 Result := '';
769 {$endif}
770 {$ifdef wince}
771 Result := '\';
772 {$endif}
773 {$ifdef unix}
774 Result := '/';
775 {$endif}
776 {$ifdef HASAMIGA}
777 Result := '';
778 {$endif}
779 end;
780
GetRootPathnull781 function TCustomShellTreeView.GetRootPath: string;
782 begin
783 if FRoot <> '' then
784 Result := FRoot
785 else
786 Result := GetBasePath();
787 if Result <> '' then
788 Result := IncludeTrailingPathDelimiter(Result);
789 end;
790
791 { Returns true if at least one item was added, false otherwise }
PopulateTreeNodeWithFilesnull792 function TCustomShellTreeView.PopulateTreeNodeWithFiles(
793 ANode: TTreeNode; ANodePath: string): Boolean;
794 var
795 i: Integer;
796 Files: TStringList;
797 NewNode: TTreeNode;
798
799 function HasSubDir(Const ADir: String): Boolean;
800 var
801 SR: TSearchRec;
802 FindRes: LongInt;
803 Attr: Longint;
804 IsHidden: Boolean;
805 begin
806 Result:=False;
807 try
808 Attr := faDirectory;
809 if (otHidden in fObjectTypes) then Attr := Attr or faHidden{%H-};
810 FindRes := FindFirstUTF8(AppendPathDelim(ADir) + AllFilesMask, Attr , SR);
811 while (FindRes = 0) do
812 begin
813 if ((SR.Attr and faDirectory <> 0) and (SR.Name <> '.') and
814 (SR.Name <> '..')) then
815 begin
816 IsHidden := ((Attr and faHidden{%H-}) > 0);
817 if not (IsHidden and (not ((otHidden in fObjectTypes)))) then
818 begin
819 Result := True;
820 Break;
821 end;
822 end;
823 FindRes := FindNextUtf8(SR);
824 end;
825 finally
826 FindCloseUTF8(SR);
827 end; //try
828 end;
829
830 begin
831 Result := False;
832 // avoids crashes in the IDE by not populating during design
833 if (csDesigning in ComponentState) then Exit;
834
835 Files := TStringList.Create;
836 try
837 Files.OwnsObjects := True;
838 GetFilesInDir(ANodePath, AllFilesMask, FObjectTypes, Files, FFileSortType);
839 Result := Files.Count > 0;
840
841 for i := 0 to Files.Count - 1 do
842 begin
843 NewNode := Items.AddChildObject(ANode, Files.Strings[i], nil);
844 TShellTreeNode(NewNode).FFileInfo := TFileItem(Files.Objects[i]).FileInfo;
845 TShellTreeNode(NewNode).SetBasePath(TFileItem(Files.Objects[i]).FBasePath);
846
847 if (fObjectTypes * [otNonFolders] = []) then
848 NewNode.HasChildren := (TShellTreeNode(NewNode).IsDirectory and
849 HasSubDir(AppendpathDelim(ANodePath)+Files[i]))
850 else
851 NewNode.HasChildren := TShellTreeNode(NewNode).IsDirectory;
852 end;
853 finally
854 Files.Free;
855 end;
856 end;
857
858 procedure TCustomShellTreeView.PopulateWithBaseFiles;
859 {$if defined(windows) and not defined(wince)}
860 var
861 r: LongWord;
862 Drives: array[0..128] of char;
863 pDrive: PChar;
864 NewNode: TTreeNode;
865 begin
866 // avoids crashes in the IDE by not populating during design
867 if (csDesigning in ComponentState) then Exit;
868 Items.Clear;
869 r := GetLogicalDriveStrings(SizeOf(Drives), Drives);
870 if r = 0 then Exit;
871 if r > SizeOf(Drives) then Exit;
872 // raise Exception.Create(SysErrorMessage(ERROR_OUTOFMEMORY));
873 pDrive := Drives;
874 while pDrive^ <> #0 do
875 begin
876 NewNode := Items.AddChildObject(nil, ExcludeTrailingBackslash(pDrive), pDrive);
877 //Yes, we want to remove the backslash,so don't use ChompPathDelim here
878 TShellTreeNode(NewNode).FFileInfo.Name := ExcludeTrailingBackslash(pDrive);
879 //On NT platforms drive-roots really have these attributes
880 TShellTreeNode(NewNode).FFileInfo.Attr := faDirectory + faSysFile + faHidden;
881 TShellTreeNode(NewNode).SetBasePath('');
882 NewNode.HasChildren := True;
883 Inc(pDrive, 4);
884 end;
885 end;
886 {$else}
887 var
888 NewNode: TTreeNode;
889 begin
890 // avoids crashes in the IDE by not populating during design
891 // also do not populate before loading is done
892 if ([csDesigning, csLoading] * ComponentState <> []) then Exit;
893 Items.Clear;
894
895 // This allows showing "/" in Linux, but in Windows it makes no sense to show the base
896 if GetBasePath() <> '' then
897 begin
898 NewNode := Items.AddChild(nil, GetBasePath());
899 NewNode.HasChildren := True;
900 PopulateTreeNodeWithFiles(NewNode, GetBasePath());
901 NewNode.Expand(False);
902 end
903 else
904 PopulateTreeNodeWithFiles(nil, GetBasePath());
905 end;
906 {$endif}
907
908 procedure TCustomShellTreeView.DoSelectionChanged;
909 var
910 ANode: TTreeNode;
911 CurrentNodePath: String;
912 begin
913 inherited DoSelectionChanged;
914 ANode := Selected;
915 if Assigned(FShellListView) and Assigned(ANode) then
916 begin
917 //You cannot rely on HasChildren here, because it can become FALSE when user
918 //clicks the expand sign and folder is empty
919 //Issue 0027571
920 CurrentNodePath := ChompPathDelim(GetPathFromNode(ANode));
921 if TShellTreeNode(ANode).IsDirectory then
922 begin
923 //Note: the folder may have been deleted in the mean time
924 //an exception will be raised by the next line in that case
925 FShellListView.Root := GetPathFromNode(ANode)
926 end
927 else
928 begin
929 if not FileExistsUtf8(CurrentNodePath) then
930 Raise EShellCtrl.CreateFmt(sShellCtrlsSelectedItemDoesNotExists,[CurrentNodePath]);
931 if Assigned(Anode.Parent) then
932 FShellListView.Root := GetPathFromNode(ANode.Parent)
933 else
934 FShellListView.Root := '';
935 end;
936 end;
937 end;
938
TCustomShellTreeView.GetPathFromNodenull939 function TCustomShellTreeView.GetPathFromNode(ANode: TTreeNode): string;
940 begin
941 if Assigned(ANode) then
942 begin
943 Result := TShellTreeNode(ANode).FullFilename;
944 if TShellTreeNode(ANode).IsDirectory then
945 Result := AppendPathDelim(Result);
946 if not FilenameIsAbsolute(Result) then
947 Result := GetRootPath() + Result; // Include root directory
948 end
949 else
950 Result := '';
951 end;
952
953
954 procedure TCustomShellTreeView.Refresh(ANode: TTreeNode);
955 //nil will refresh root
956 var
957 RootNodeText: String;
958 IsRoot: Boolean;
959 begin
960 if (Items.Count = 0) then Exit;
961 {$ifdef debug_shellctrls}
962 debugln(['TCustomShellTreeView.Refresh: GetFirstVisibleNode.Text = "',Items.GetFirstVisibleNode.Text,'"']);
963 {$endif}
964
965 IsRoot := (ANode = nil) or ((ANode = Items.GetFirstVisibleNode) and (GetRootPath <> ''));
966 {$ifdef debug_shellctrls}
967 debugln(['IsRoot = ',IsRoot]);
968 {$endif}
969
970
971 if (ANode = nil) and (GetRootPath <> '') then ANode := Items.GetFirstVisibleNode;
972 if IsRoot then
973 begin
974 if Assigned(ANode) then
975 RootNodeText := ANode.Text //this may differ from FRoot, so don't use FRoot here
976 else
977 RootNodeText := GetRootPath;
978 {$ifdef debug_shellctrls}
979 debugln(['IsRoot = TRUE, RootNodeText = "',RootNodeText,'"']);
980 {$endif}
981
982
983 FRoot := #0; //invalidate FRoot
984 SetRoot(RootNodeText); //re-initialize the entire tree
985 end
986 else
987 begin
988 ANode.Expand(False);
989 end;
990 end;
991
GetPathnull992 function TCustomShellTreeView.GetPath: string;
993 begin
994 Result := GetPathFromNode(Selected);
995 end;
996
997 {
998 SetPath: Path can be
999 - Absolute like '/usr/lib'
1000 - Relative like 'foo/bar'
1001 This can be relative to:
1002 - Self.Root (which takes precedence over)
1003 - Current directory
1004 }
1005 procedure TCustomShellTreeView.SetPath(AValue: string);
1006 var
1007 sl: TStringList;
1008 Node: TTreeNode;
1009 i: integer;
1010 FQRootPath, RelPath: String;
1011 RootIsAbsolute: Boolean;
1012 IsRelPath: Boolean;
1013
1014 function GetAdjustedNodeText(ANode: TTreeNode): String;
1015 begin
1016 if (ANode = Items.GetFirstVisibleNode) and (FQRootPath <> '') then
1017 begin
1018 if not RootIsAbsolute then
1019 Result := ''
1020 else
1021 Result := FQRootPath;
1022 end
1023 else Result := ANode.Text;
1024 end;
1025
1026 function Exists(Fn: String): Boolean;
1027 //Fn should be fully qualified
1028 var
1029 Attr: LongInt;
1030 Dirs: TStringList;
1031 i: Integer;
1032 begin
1033 Result := False;
1034 Attr := FileGetAttrUtf8(Fn);
1035 {$ifdef debug_shellctrls}
1036 debugln(['TCustomShellTreeView.SetPath.Exists: Attr = ', Attr]);
1037 {$endif}
1038 if (Attr = -1) then Exit;
1039 if not (otNonFolders in FObjectTypes) then
1040 Result := ((Attr and faDirectory) > 0)
1041 else
1042 Result := True;
1043 {$ifdef debug_shellctrls}
1044 debugln(['TCustomShellTreeView.SetPath.Exists: Result = ',Result]);
1045 {$endif}
1046 end;
1047
1048 function PathIsDriveRoot({%H-}Path: String): Boolean; {$if not (defined(windows) and not defined(wince))}inline;{$endif}
1049 //WinNT filesystem reports faHidden on all physical drive-roots (e.g. C:\)
1050 begin
1051 {$if defined(windows) and not defined(wince)}
1052 Result := (Length(Path) = 3) and
1053 (Upcase(Path[1]) in ['A'..'Z']) and
1054 (Path[2] = DriveSeparator) and
1055 (Path[3] in AllowDirectorySeparators);
1056 {$else}
1057 Result := False;
1058 {$endif windows}
1059 end;
1060
1061 function ContainsHiddenDir(Fn: String): Boolean;
1062 var
1063 i: Integer;
1064 Attr: LongInt;
1065 Dirs: TStringList;
1066 RelPath: String;
1067 begin
1068 //if fn=root then always return false
1069 if (CompareFileNames(Fn, FQRootPath) = 0) then
1070 Result := False
1071 else
1072 begin
1073 Attr := FileGetAttrUtf8(Fn);
1074 Result := ((Attr and faHidden{%H-}) = faHidden{%H-}) and not PathIsDriveRoot(Fn);
1075 if not Result then
1076 begin
1077 //it also is not allowed that any folder above is hidden
1078 Fn := ChompPathDelim(Fn);
1079 Fn := ExtractFileDir(Fn);
1080 Dirs := TStringList.Create;
1081 try
1082 Dirs.StrictDelimiter := True;
1083 Dirs.Delimiter := PathDelim;
1084 Dirs.DelimitedText := Fn;
1085 Fn := '';
1086 for i := 0 to Dirs.Count - 1 do
1087 begin
1088 if (i = 0) then
1089 Fn := Dirs.Strings[i]
1090 else
1091 Fn := Fn + PathDelim + Dirs.Strings[i];
1092 if (Fn = '') then Continue;
1093 RelPath := CreateRelativePath(Fn, FQRootPath, False, True);
1094 //don't check if Fn now is "higher up the tree" than the current root
1095 if (RelPath = '') or ((Length(RelPath) > 1) and (RelPath[1] = '.') and (RelPath[2] = '.')) then
1096 begin
1097 {$ifdef debug_shellctrls}
1098 debugln(['TCustomShellTreeView.SetPath.ContainsHidden: Fn is higher: ',Fn]);
1099 {$endif}
1100 Continue;
1101 end;
1102 {$if defined(windows) and not defined(wince)}
1103 if (Length(Fn) = 2) and (Fn[2] = ':') then Continue;
1104 {$endif}
1105 Attr := FileGetAttrUtf8(Fn);
1106 if (Attr <> -1) and ((Attr and faHidden{%H-}) > 0) and not PathIsDriveRoot(Fn) then
1107 begin
1108 Result := True;
1109 {$ifdef debug_shellctrls}
1110 debugln(['TCustomShellTreeView.SetPath.Exists: a subdir is hidden: Result := False']);
1111 {$endif}
1112 Break;
1113 end;
1114 end;
1115 finally
1116 Dirs.Free;
1117 end;
1118 end;
1119 end;
1120 end;
1121
1122 begin
1123 RelPath := '';
1124
1125 {$ifdef debug_shellctrls}
1126 debugln(['SetPath: GetRootPath = "',getrootpath,'"',' AValue=',AValue]);
1127 {$endif}
1128 if (GetRootPath <> '') then
1129 //FRoot is already Expanded in SetRoot, just add PathDelim if needed
1130 FQRootPath := AppendPathDelim(GetRootPath)
1131 else
1132 FQRootPath := '';
1133 RootIsAbsolute := (FQRootPath = '') or (FQRootPath = PathDelim)
1134 or ((Length(FQRootPath) = 3) and (FQRootPath[2] = ':') and (FQRootPath[3] = PathDelim));
1135
1136 {$ifdef debug_shellctrls}
1137 debugln(['SetPath: FQRootPath = ',fqrootpath]);
1138 debugln(['SetPath: RootIsAbsolute = ',RootIsAbsolute]);
1139 debugln(['SetPath: FilenameIsAbsolute = ',FileNameIsAbsolute(AValue)]);
1140 {$endif}
1141
1142 if not FileNameIsAbsolute(AValue) then
1143 begin
1144 if Exists(FQRootPath + AValue) then
1145 begin
1146 //Expand it, since it may be in the form of ../../foo
1147 AValue := ExpandFileNameUtf8(FQRootPath + AValue);
1148 end
1149 else
1150 begin
1151 //don't expand Avalue yet, we may need it in error message
1152 if not Exists(ExpandFileNameUtf8(AValue)) then
1153 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidPath,[ExpandFileNameUtf8(FQRootPath + AValue)]);
1154 //Directory (or file) exists
1155 //Make it fully qualified
1156 AValue := ExpandFileNameUtf8(AValue);
1157 end;
1158 end
1159 else
1160 begin
1161 //AValue is an absoulte path to begin with
1162 //if not DirectoryExistsUtf8(AValue) then
1163 if not Exists(AValue) then
1164 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidPath,[AValue]);
1165 end;
1166
1167 //AValue now is a fully qualified path and it exists
1168 //Now check if it is a subdirectory of FQRootPath
1169 //RelPath := CreateRelativePath(AValue, FQRootPath, False);
1170 IsRelPath := (FQRootPath = '') or TryCreateRelativePath(AValue, FQRootPath, False, True, RelPath);
1171
1172 {$ifdef debug_shellctrls}
1173 debugln('TCustomShellTreeView.SetPath: ');
1174 debugln([' IsRelPath = ',IsRelPath]);
1175 debugln([' RelPath = "',RelPath,'"']);
1176 debugln([' FQRootPath = "',FQRootPath,'"']);
1177 {$endif}
1178
1179 if (not IsRelpath) or ((RelPath <> '') and ((Length(RelPath) > 1) and (RelPath[1] = '.') and (RelPath[2] = '.'))) then
1180 begin
1181 // CreateRelativePath retruns a string beginning with ..
1182 // so AValue is not a subdirectory of FRoot
1183 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidPathRelative,[AValue, FQRootPath]);
1184 end;
1185
1186 if (RelPath = '') and (FQRootPath = '') then
1187 RelPath := AValue;
1188 {$ifdef debug_shellctrls}
1189 debugln(['RelPath = ',RelPath]);
1190 {$endif}
1191
1192 if (RelPath = '') then
1193 begin
1194 {$ifdef debug_shellctrls}
1195 debugln('Root selected');
1196 {$endif}
1197 Node := Items.GetFirstVisibleNode;
1198 if Assigned(Node) then
1199 begin
1200 Node.Expanded := True;
1201 Node.Selected := True;
1202 end;
1203 Exit;
1204 end;
1205
1206 if not (otHidden in FObjectTypes) and ContainsHiddenDir(AValue) then
1207 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidPath,[AValue, FQRootPath]);
1208
1209 sl := TStringList.Create;
1210 sl.Delimiter := PathDelim;
1211 sl.StrictDelimiter := True;
1212 sl.DelimitedText := RelPath;
1213 if (sl.Count > 0) and (sl[0] = '') then // This happens when root dir is empty
1214 sl[0] := PathDelim; // and PathDelim was the first char
1215 if (sl.Count > 0) and (sl[sl.Count-1] = '') then sl.Delete(sl.Count-1); //remove last empty string
1216 if (sl.Count = 0) then
1217 begin
1218 sl.Free;
1219 Exit;
1220 end;
1221
1222 {$ifdef debug_shellctrls}
1223 for i := 0 to sl.Count - 1 do debugln(['sl[',i,']="',sl[i],'"']);
1224 {$endif}
1225
1226
1227
1228 BeginUpdate;
1229 try
1230 Node := Items.GetFirstVisibleNode;
1231 {$ifdef debug_shellctrls}
1232 if assigned(node) then debugln(['GetFirstVisibleNode = ',GetAdjustedNodeText(Node)]);
1233 {$endif}
1234 //Root node doesn't have Siblings in this case, we need one level down the tree
1235 if (GetRootPath <> '') and Assigned(Node) then
1236 begin
1237 {$ifdef debug_shellctrls}
1238 debugln('Root node doesn''t have Siblings');
1239 {$endif}
1240 Node := Node.GetFirstVisibleChild;
1241 {$ifdef debug_shellctrls}
1242 debugln(['Node = ',GetAdjustedNodeText(Node)]);
1243 {$endif}
1244 //I don't know why I wrote this in r44893, but it seems to be wrong so I comment it out
1245 //for the time being (2015-12-05: BB)
1246 //if RootIsAbsolute then sl.Delete(0);
1247 end;
1248
1249 for i := 0 to sl.Count-1 do
1250 begin
1251 {$ifdef debug_shellctrls}
1252 DbgOut(['i=',i,' sl[',i,']=',sl[i],' ']);
1253 if Node <> nil then DbgOut(['GetAdjustedNodeText = ',GetAdjustedNodeText(Node)])
1254 else DbgOut('Node = NIL');
1255 debugln;
1256 {$endif}
1257 while (Node <> Nil) and
1258 {$IF defined(CaseInsensitiveFilenames) or defined(NotLiteralFilenames)}
1259 (Utf8LowerCase(GetAdjustedNodeText(Node)) <> Utf8LowerCase(sl[i]))
1260 {$ELSE}
1261 (GetAdjustedNodeText(Node) <> sl[i])
1262 {$ENDIF}
1263 do
1264 begin
1265 {$ifdef debug_shellctrls}
1266 DbgOut([' i=',i,' "',GetAdjustedNodeText(Node),' <> ',sl[i],' -> GetNextVisibleSibling -> ']);
1267 {$endif}
1268 Node := Node.GetNextVisibleSibling;
1269 {$ifdef debug_shellctrls}
1270 if Node <> nil then DbgOut(['GetAdjustedNodeText = ',GetAdjustedNodeText(Node)])
1271 else DbgOut('Node = NIL');
1272 debugln;
1273 {$endif}
1274 end;
1275 if Node <> Nil then
1276 begin
1277 Node.Expanded := True;
1278 Node.Selected := True;
1279 Node := Node.GetFirstVisibleChild;
1280 end
1281 else
1282 Break;
1283 end;
1284 finally
1285 sl.free;
1286 EndUpdate;
1287 end;
1288 end;
1289
1290
1291 { TCustomShellListView }
1292
1293 procedure TCustomShellListView.SetShellTreeView(
1294 const Value: TCustomShellTreeView);
1295 var
1296 Tmp: TCustomShellTreeView;
1297 begin
1298 if FShellTreeView = Value then Exit;
1299 if FShellTreeView <> nil then
1300 begin
1301 Tmp := FShellTreeView;
1302 FShellTreeView := nil;
1303 Tmp.ShellListView := nil;
1304 end;
1305
1306 FShellTreeView := Value;
1307
1308 if not (csDestroying in ComponentState) then
1309 Clear;
1310
1311 if Value <> nil then
1312 begin
1313 FRoot := Value.GetPathFromNode(Value.Selected);
1314 PopulateWithRoot();
1315
1316 // Also update the pair, but only if necessary to avoid circular calls of the setters
1317 if Value.ShellListView <> Self then Value.ShellListView := Self;
1318 end;
1319
1320 end;
1321
1322 procedure TCustomShellListView.SetMask(const AValue: string);
1323 begin
1324 if AValue <> FMask then
1325 begin
1326 FMask := AValue;
1327 Clear;
1328 Items.Clear;
1329 PopulateWithRoot();
1330 end;
1331 end;
1332
1333 procedure TCustomShellListView.SetRoot(const Value: string);
1334 begin
1335 if FRoot <> Value then
1336 begin
1337 //Delphi raises an unspecified exception in this case, but don't crash the IDE at designtime
1338 if not (csDesigning in ComponentState)
1339 and (Value <> '')
1340 and not DirectoryExistsUtf8(ExpandFilenameUtf8(Value)) then
1341 Raise EInvalidPath.CreateFmt(sShellCtrlsInvalidRoot,[Value]);
1342 FRoot := Value;
1343 Clear;
1344 Items.Clear;
1345 PopulateWithRoot();
1346 end;
1347 end;
1348
1349 constructor TCustomShellListView.Create(AOwner: TComponent);
1350 begin
1351 inherited Create(AOwner);
1352
1353 // Initial property values
1354 ViewStyle := vsReport;
1355 ObjectTypes := [otNonFolders];
1356
1357 Self.Columns.Add;
1358 Self.Columns.Add;
1359 Self.Columns.Add;
1360 Self.Column[0].Caption := sShellCtrlsName;
1361 Self.Column[1].Caption := sShellCtrlsSize;
1362 Self.Column[2].Caption := sShellCtrlsType;
1363 // Initial sizes, necessary under Windows CE
1364 Resize;
1365 end;
1366
1367 destructor TCustomShellListView.Destroy;
1368 begin
1369 ShellTreeView := nil;
1370 inherited Destroy;
1371 end;
1372
1373 procedure TCustomShellListView.PopulateWithRoot();
1374 var
1375 i: Integer;
1376 Files: TStringList;
1377 NewItem: TListItem;
1378 CurFileName, CurFilePath: string;
1379 CurFileSize: Int64;
1380 begin
1381 // avoids crashes in the IDE by not populating during design
1382 if (csDesigning in ComponentState) then Exit;
1383
1384 // Check inputs
1385 if Trim(FRoot) = '' then Exit;
1386
1387 Files := TStringList.Create;
1388 try
1389 Files.OwnsObjects := True;
1390 TCustomShellTreeView.GetFilesInDir(FRoot, FMask, FObjectTypes, Files);
1391
1392 for i := 0 to Files.Count - 1 do
1393 begin
1394 NewItem := Items.Add;
1395 CurFileName := Files.Strings[i];
1396 CurFilePath := IncludeTrailingPathDelimiter(FRoot) + CurFileName;
1397 // First column - Name
1398 NewItem.Caption := CurFileName;
1399 // Second column - Size
1400 // The raw size in bytes is stored in the data part of the item
1401 CurFileSize := FileSize(CurFilePath); // in Bytes
1402 NewItem.Data := Pointer(PtrInt(CurFileSize));
1403 if CurFileSize < 1024 then
1404 NewItem.SubItems.Add(Format(sShellCtrlsBytes, [IntToStr(CurFileSize)]))
1405 else if CurFileSize < 1024 * 1024 then
1406 NewItem.SubItems.Add(Format(sShellCtrlsKB, [IntToStr(CurFileSize div 1024)]))
1407 else
1408 NewItem.SubItems.Add(Format(sShellCtrlsMB, [IntToStr(CurFileSize div (1024 * 1024))]));
1409 // Third column - Type
1410 NewItem.SubItems.Add(ExtractFileExt(CurFileName));
1411 if Assigned(FOnFileAdded) then FOnFileAdded(Self,NewItem);
1412 end;
1413 Sort;
1414 finally
1415 Files.Free;
1416 end;
1417 end;
1418
1419 procedure TCustomShellListView.Resize;
1420 begin
1421 inherited Resize;
1422 {$ifdef DEBUG_SHELLCTRLS}
1423 debugln(':>TCustomShellListView.HandleResize');
1424 {$endif}
1425
1426 // The correct check is with count,
1427 // if Column[0] <> nil then
1428 // will raise an exception
1429 if Self.Columns.Count < 3 then Exit;
1430
1431 // If the space available is small,
1432 // alloc a larger percentage to the secondary
1433 // fields
1434 if Width < 400 then
1435 begin
1436 Column[0].Width := (50 * Width) div 100;
1437 Column[1].Width := (25 * Width) div 100;
1438 Column[2].Width := (25 * Width) div 100;
1439 end
1440 else
1441 begin
1442 Column[0].Width := (70 * Width) div 100;
1443 Column[1].Width := (15 * Width) div 100;
1444 Column[2].Width := (15 * Width) div 100;
1445 end;
1446
1447 {$ifdef DEBUG_SHELLCTRLS}
1448 debugln([':<TCustomShellListView.HandleResize C0.Width=',
1449 Column[0].Width, ' C1.Width=', Column[1].Width,
1450 ' C2.Width=', Column[2].Width]);
1451 {$endif}
1452 end;
1453
TCustomShellListView.GetPathFromItemnull1454 function TCustomShellListView.GetPathFromItem(ANode: TListItem): string;
1455 begin
1456 Result := IncludeTrailingPathDelimiter(FRoot) + ANode.Caption;
1457 end;
1458
1459 procedure Register;
1460 begin
1461 RegisterComponents('Misc',[TShellTreeView, TShellListView]);
1462 end;
1463
1464 end.
1465