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