DriveView.pas 82 KB

12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951
  1. unit DriveView;
  2. {==================================================================
  3. Component TDriveView / Version 2.6, January 2000
  4. ==================================================================
  5. Description:
  6. ============
  7. Displays the the directory structure of all drives as treeview
  8. with shell icons. Complete drag&Drop support for files and
  9. directories.
  10. Author:
  11. =======
  12. (c) Ingo Eckel 1998, 1999
  13. Sodener Weg 38
  14. 65812 Bad Soden
  15. Germany
  16. Modifications (for WinSCP):
  17. ===========================
  18. (c) Martin Prikryl 2004
  19. V2.6:
  20. - Shows "shared"-symbol with directories
  21. - Delphi5 compatible
  22. For detailed documentation and history see TDriveView.htm.
  23. ==================================================================}
  24. interface
  25. {$WARN SYMBOL_PLATFORM OFF}
  26. uses
  27. Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, ComObj,
  28. Dialogs, ComCtrls, ShellApi, CommCtrl, ExtCtrls, ActiveX, ShlObj,
  29. DirView, ShellDialogs, DragDrop, DragDropFilesEx, FileChanges, FileOperator,
  30. DiscMon, IEDriveInfo, IEListView, BaseUtils, CustomDirView,
  31. CustomDriveView, System.Generics.Collections, CompThread;
  32. type
  33. EInvalidDirName = class(Exception);
  34. ENodeNotAssigned = class(Exception);
  35. TDriveStatus = class
  36. Scanned: Boolean; // Drive allready scanned?
  37. Verified: Boolean; // Drive completly scanned?
  38. RootNode: TTreeNode; // Rootnode to drive
  39. RootNodeIndex: Integer;
  40. DiscMonitor: TDiscMonitor; // Monitor thread
  41. ChangeTimer: TTimer; // Change timer for the monitor thread
  42. DefaultDir: string; // Current directory
  43. end;
  44. TDriveStatusPair = TPair<string, TDriveStatus>;
  45. TScanDirInfo = record
  46. SearchNewDirs: Boolean;
  47. StartNode: TTreeNode;
  48. DriveType: Integer;
  49. end;
  50. PScanDirInfo = ^TScanDirInfo;
  51. TDriveView = class;
  52. TSubDirReaderSchedule = class
  53. Node: TTreeNode;
  54. Path: string;
  55. Deleted: Boolean;
  56. Processed: Boolean;
  57. end;
  58. TNodeData = class
  59. private
  60. FDirName: string;
  61. FAttr: Integer;
  62. FScanned: Boolean;
  63. FData: Pointer;
  64. FIsRecycleBin: Boolean;
  65. FIconEmpty: Boolean;
  66. FSchedule: TSubDirReaderSchedule;
  67. public
  68. DelayedSrec: TSearchRec;
  69. DelayedExclude: TStringList;
  70. constructor Create;
  71. destructor Destroy; override;
  72. property DirName: string read FDirName write FDirName;
  73. property Attr: Integer read FAttr write FAttr;
  74. property Scanned: Boolean read FScanned write FScanned;
  75. property Data: Pointer read FData write FData;
  76. property IsRecycleBin: Boolean read FIsRecycleBin;
  77. property IconEmpty: Boolean read FIconEmpty write FIconEmpty;
  78. property Schedule: TSubDirReaderSchedule read FSchedule write FSchedule;
  79. end;
  80. TDriveTreeNode = class(TTreeNode)
  81. procedure Assign(Source: TPersistent); override;
  82. end;
  83. TSubDirReaderThread = class(TCompThread)
  84. public
  85. destructor Destroy; override;
  86. procedure Terminate; override;
  87. protected
  88. constructor Create(DriveView: TDriveView);
  89. procedure Add(Node: TTreeNode; Path: string);
  90. procedure Delete(Node: TTreeNode);
  91. function Detach: Integer;
  92. procedure Reattach(Count: Integer);
  93. procedure Execute; override;
  94. private
  95. FDriveView: TDriveView;
  96. FEvent: THandle;
  97. FQueue: TStack<TSubDirReaderSchedule>;
  98. FResults: TQueue<TSubDirReaderSchedule>;
  99. FSection: TRTLCriticalSection;
  100. FTimer: TTimer;
  101. FWindowHandle: HWND;
  102. procedure TriggerEvent;
  103. procedure ScheduleProcess;
  104. procedure Process;
  105. function ProcessResult: Boolean;
  106. procedure Timer(Sender: TObject);
  107. procedure WndProc(var Msg: TMessage);
  108. function DetachList(List: TEnumerable<TSubDirReaderSchedule>): Integer;
  109. procedure DestroyScheduleList(List: TEnumerable<TSubDirReaderSchedule>);
  110. end;
  111. TTreeNodeArray = array of TTreeNode;
  112. TDriveView = class(TCustomDriveView)
  113. private
  114. FDriveStatus: TObjectDictionary<string, TDriveStatus>;
  115. FConfirmDelete: Boolean;
  116. FConfirmOverwrite: Boolean;
  117. FWatchDirectory: Boolean;
  118. FDirectory: string;
  119. FChangeFlag: Boolean;
  120. FLastDir: string;
  121. FValidateFlag: Boolean;
  122. FSysColorChangePending: Boolean;
  123. FCreating: Boolean;
  124. FForceRename: Boolean;
  125. FRenameNode: TTreeNode;
  126. FLastRenameName: string;
  127. FPrevSelected: TTreeNode;
  128. FPrevSelectedIndex: Integer;
  129. FChangeTimerSuspended: Integer;
  130. FSubDirReaderThread: TSubDirReaderThread;
  131. FDelayedNodes: TStringList;
  132. FDelayedNodeTimer: TTimer;
  133. FRecreateScheduledCount: Integer;
  134. // Additional events:
  135. FOnDisplayContextMenu: TNotifyEvent;
  136. FOnNeedHiddenDirectories: TNotifyEvent;
  137. // used components:
  138. FDirView: TDirView;
  139. FFileOperator: TFileOperator;
  140. FChangeInterval: Cardinal;
  141. // Drag&drop:
  142. FLastPathCut: string;
  143. // Drag&drop helper functions:
  144. procedure SignalDirDelete(Sender: TObject; Files: TStringList);
  145. function GetSubDir(var SRec: TSearchRec): Boolean;
  146. function FindFirstSubDir(Path: string; var SRec: TSearchRec): Boolean;
  147. function FindNextSubDir(var SRec: TSearchRec): Boolean;
  148. procedure ReadSubDirs(Node: TTreeNode);
  149. procedure CancelDelayedNode(Node: TTreeNode);
  150. procedure DelayedNodeTimer(Sender: TObject);
  151. function ReadSubDirsBatch(Node: TTreeNode; var SRec: TSearchRec; CheckInterval, Limit: Integer): Boolean;
  152. procedure UpdateDelayedNodeTimer;
  153. function DoSearchSubDirs(
  154. ParentNode: TTreeNode; Path: string; Level: Integer; ExistingOnly: Boolean;
  155. var SelectionHierarchy: TTreeNodeArray; var SelectionHierarchyHeight: Integer): TTreeNode;
  156. function SearchSubDirs(
  157. ParentNode: TTreeNode; Path: string; Level: Integer; ExistingOnly: Boolean;
  158. var SelectionHierarchy: TTreeNodeArray; var SelectionHierarchyHeight: Integer): TTreeNode;
  159. // Callback-functions used by iteratesubtree:
  160. function CallBackValidateDir(var Node: TTreeNode; Data: Pointer): Boolean;
  161. procedure DeleteNode(Node: TTreeNode);
  162. // Notification procedures used by component TDiscMonitor:
  163. procedure ChangeDetected(Sender: TObject; const Directory: string;
  164. var SubdirsChanged: Boolean);
  165. procedure ChangeInvalid(Sender: TObject; const Directory: string; const ErrorStr: string);
  166. // Notification procedure used by component TTimer:
  167. procedure ChangeTimerOnTimer(Sender: TObject);
  168. protected
  169. procedure SetSelected(Node: TTreeNode);
  170. procedure SetWatchDirectory(Value: Boolean);
  171. procedure SetDirView(Value: TDirView);
  172. procedure SetDirectory(Value: string); override;
  173. function DoScanDir(FromNode: TTreeNode): Boolean;
  174. procedure AddChildNode(ParentNode: TTreeNode; ParentPath: string; SRec: TSearchRec);
  175. procedure CreateWatchThread(Drive: string);
  176. function NodeWatched(Node: TTreeNode): Boolean;
  177. procedure TerminateWatchThread(Drive: string);
  178. function WatchThreadActive: Boolean; overload;
  179. function WatchThreadActive(Drive: string): Boolean; overload;
  180. procedure SubscribeDriveNotifications(Drive: string);
  181. procedure DriveRemoved(Drive: string);
  182. procedure DriveRemoving(Drive: string);
  183. procedure RefreshRootNodes(Floppy: Boolean = False);
  184. procedure DriveNotification(Notification: TDriveNotification; Drive: string);
  185. function DirAttrMask: Integer;
  186. function CreateDriveStatus: TDriveStatus;
  187. procedure ValidateDirectoryEx(Node: TTreeNode; Recurse: TRecursiveScan;
  188. NewDirs: Boolean); override;
  189. procedure RebuildTree; override;
  190. procedure CreateWnd; override;
  191. procedure DestroyWnd; override;
  192. procedure Edit(const Item: TTVItem); override;
  193. procedure WMUserRename(var Message: TMessage); message WM_USER_RENAME;
  194. procedure CMSysColorChange(var Message: TMessage); message CM_SYSCOLORCHANGE;
  195. function GetCustomDirView: TCustomDirView; override;
  196. procedure SetCustomDirView(Value: TCustomDirView); override;
  197. function NodePath(Node: TTreeNode): string; override;
  198. function NodePathExists(Node: TTreeNode): Boolean; override;
  199. function NodeColor(Node: TTreeNode): TColor; override;
  200. function FindPathNode(Path: string): TTreeNode; override;
  201. function DoFindNodeToPath(Path: string; ExistingOnly: Boolean): TTreeNode;
  202. function CreateNode: TTreeNode; override;
  203. function DDSourceEffects: TDropEffectSet; override;
  204. procedure DDChooseEffect(KeyState: Integer; var Effect: Integer; PreferredEffect: Integer); override;
  205. function DragCompleteFileList: Boolean; override;
  206. function DDExecute: TDragResult; override;
  207. function CanPasteFromClipBoard: Boolean;
  208. procedure PasteFromClipBoard(Node: TTreeNode);
  209. procedure PerformDragDropFileOperation(Node: TTreeNode; Effect: Integer); override;
  210. procedure ClearCutState;
  211. public
  212. property Images;
  213. property StateImages;
  214. property Items stored False;
  215. property Selected Write SetSelected stored False;
  216. property DragImageList: TDragImageList read FDragImageList;
  217. procedure EmptyClipboard; dynamic;
  218. procedure EmptyClipboardIfCut; override;
  219. // Drive handling:
  220. function GetDriveStatus(Drive: string): TDriveStatus;
  221. function GetDriveTypetoNode(Node: TTreeNode): Integer; // Returns DRIVE_CDROM etc..
  222. function GetDriveToNode(Node: TTreeNode): string;
  223. procedure ScanDrive(Drive: string);
  224. function GetDrives: TStrings;
  225. // Node handling:
  226. procedure SetImageIndex(Node: TTreeNode); virtual;
  227. function FindNodeToPath(Path: string): TTreeNode; override;
  228. function TryFindNodeToPath(Path: string): TTreeNode; override;
  229. function RootNode(Node: TTreeNode): TTreeNode;
  230. function GetDirName(Node: TTreeNode): string;
  231. function GetDisplayName(Node: TTreeNode): string;
  232. function NodePathName(Node: TTreeNode): string; override;
  233. function NodeIsRecycleBin(Node: TTreeNode): Boolean; override;
  234. procedure DirHasNoChildren(Path: string); override;
  235. constructor Create(AOwner: TComponent); override;
  236. destructor Destroy; override;
  237. // Menu-handling:
  238. procedure DisplayContextMenu(Node: TTreeNode; Point: TPoint); override;
  239. procedure DisplayPropertiesMenu(Node: TTreeNode); override;
  240. // Watchthread handling:
  241. procedure StartWatchThread; override;
  242. procedure StopWatchThread; override;
  243. procedure SuspendChangeTimer; override;
  244. procedure ResumeChangeTimer; override;
  245. procedure StartAllWatchThreads;
  246. procedure StopAllWatchThreads;
  247. procedure ValidateCurrentDirectoryIfNotMonitoring; override;
  248. (* Modified Events: *)
  249. procedure GetImageIndex(Node: TTreeNode); override;
  250. function CanEdit(Node: TTreeNode): Boolean; override;
  251. function CanChange(Node: TTreeNode): Boolean; override;
  252. function CanExpand(Node: TTreeNode): Boolean; override;
  253. procedure Delete(Node: TTreeNode); override;
  254. procedure Loaded; override;
  255. procedure KeyPress(var Key: Char); override;
  256. procedure Change(Node: TTreeNode); override;
  257. published
  258. // Additional properties:
  259. // Current selected directory:
  260. property Directory;
  261. // Confirm deleting directories:
  262. property ConfirmDelete: Boolean read FConfirmDelete write FConfirmDelete default True;
  263. // Confirm overwriting directories:
  264. property ConfirmOverwrite: Boolean read FConfirmOverwrite write FConfirmOverwrite default True;
  265. // Enable automatic update on filesystem changes:
  266. property WatchDirectory: Boolean read FWatchDirectory write SetWatchDirectory default False;
  267. // Linked component TDirView:
  268. property DirView: TDirView read FDirView write SetDirView;
  269. // Additional events:
  270. property OnDisplayContextMenu: TNotifyEvent read FOnDisplayContextMenu
  271. write FOnDisplayContextMenu;
  272. property OnBusy;
  273. property DDLinkOnExeDrag;
  274. property TargetPopUpMenu;
  275. property OnDDDragEnter;
  276. property OnDDDragLeave;
  277. property OnDDDragOver;
  278. property OnDDDrop;
  279. property OnDDQueryContinueDrag;
  280. property OnDDGiveFeedback;
  281. property OnDDDragDetect;
  282. property OnDDProcessDropped;
  283. property OnDDError;
  284. property OnDDExecuted;
  285. property OnDDFileOperation;
  286. property OnDDFileOperationExecuted;
  287. property Align;
  288. property Anchors;
  289. property AutoExpand;
  290. property BiDiMode;
  291. property BorderStyle;
  292. property BorderWidth;
  293. property ChangeDelay;
  294. property Color;
  295. property Ctl3D;
  296. property Constraints;
  297. property DoubleBuffered;
  298. // Delphi's drag&drop is not compatible with the OLE windows drag&drop:
  299. property DragKind;
  300. property DragCursor;
  301. property DragMode Default dmAutomatic;
  302. property OnDragDrop;
  303. property OnDragOver;
  304. property Enabled;
  305. property Font;
  306. property HideSelection;
  307. property HotTrack;
  308. property Indent;
  309. property ParentBiDiMode;
  310. property ParentColor;
  311. property ParentCtl3D;
  312. property ParentDoubleBuffered;
  313. property ParentFont;
  314. property ParentShowHint;
  315. property PopupMenu;
  316. property ReadOnly;
  317. property RightClickSelect;
  318. property RowSelect;
  319. property ShowButtons;
  320. property ShowHint;
  321. property ShowLines;
  322. property TabOrder;
  323. property TabStop default True;
  324. property ToolTips;
  325. property Visible;
  326. property OnChange;
  327. property OnChanging;
  328. property OnClick;
  329. property OnCollapsing;
  330. property OnCollapsed;
  331. property OnCompare;
  332. property OnDblClick;
  333. property OnDeletion;
  334. property OnEdited;
  335. property OnEditing;
  336. property OnEndDock;
  337. property OnEndDrag;
  338. property OnEnter;
  339. property OnExit;
  340. property OnExpanding;
  341. property OnExpanded;
  342. property OnGetImageIndex;
  343. property OnGetSelectedIndex;
  344. property OnKeyDown;
  345. property OnKeyPress;
  346. property OnKeyUp;
  347. property OnMouseDown;
  348. property OnMouseMove;
  349. property OnMouseUp;
  350. property OnStartDock;
  351. property OnStartDrag;
  352. property OnNeedHiddenDirectories: TNotifyEvent read FOnNeedHiddenDirectories write FOnNeedHiddenDirectories;
  353. end;
  354. var
  355. DriveViewLoadingTooLongLimit: Integer = 0;
  356. procedure Register;
  357. implementation
  358. uses
  359. PasTools, UITypes, SyncObjs, IOUtils, System.DateUtils;
  360. const
  361. msThreadChangeDelay = 50;
  362. ErrorNodeNA = '%s: Node not assigned';
  363. WM_USER_SUBDIRREADER = WM_USER_SHCHANGENOTIFY + 1;
  364. procedure Register;
  365. begin
  366. RegisterComponents('DriveDir', [TDriveView]);
  367. end;
  368. constructor TNodeData.Create;
  369. begin
  370. inherited;
  371. FAttr := 0;
  372. FScanned := False;
  373. FDirName := '';
  374. FIsRecycleBin := False;
  375. FIconEmpty := True;
  376. FSchedule := nil;
  377. DelayedExclude := nil;
  378. end;
  379. destructor TNodeData.Destroy;
  380. begin
  381. Assert(not Assigned(FSchedule));
  382. SetLength(FDirName, 0);
  383. inherited;
  384. end;
  385. // TSubDirReaderThread
  386. constructor TSubDirReaderThread.Create(DriveView: TDriveView);
  387. begin
  388. inherited Create(True);
  389. FDriveView := DriveView;
  390. FSection.Initialize;
  391. FEvent := CreateEvent(nil, False, False, nil);
  392. FQueue := TStack<TSubDirReaderSchedule>.Create;
  393. FResults := TQueue<TSubDirReaderSchedule>.Create;
  394. FTimer := TTimer.Create(FDriveView);
  395. FTimer.Enabled := False;
  396. FTimer.Interval := 200;
  397. FTimer.OnTimer := Timer;
  398. FWindowHandle := AllocateHWnd(WndProc);
  399. end;
  400. procedure TSubDirReaderThread.DestroyScheduleList(List: TEnumerable<TSubDirReaderSchedule>);
  401. var
  402. Schedule: TSubDirReaderSchedule;
  403. begin
  404. for Schedule in List do
  405. begin
  406. if not Schedule.Deleted then
  407. TNodeData(Schedule.Node.Data).Schedule := nil;
  408. Schedule.Free;
  409. end;
  410. List.Destroy;
  411. end;
  412. destructor TSubDirReaderThread.Destroy;
  413. begin
  414. inherited;
  415. DeallocateHWnd(FWindowHandle);
  416. DestroyScheduleList(FQueue);
  417. DestroyScheduleList(FResults);
  418. CloseHandle(FEvent);
  419. FTimer.Destroy;
  420. FSection.Destroy;
  421. end;
  422. procedure TSubDirReaderThread.WndProc(var Msg: TMessage);
  423. begin
  424. if Msg.Msg = WM_USER_SUBDIRREADER then
  425. ScheduleProcess
  426. else
  427. Msg.Result := DefWindowProc(FWindowHandle, Msg.Msg, Msg.wParam, Msg.lParam);
  428. end;
  429. procedure TSubDirReaderThread.Process;
  430. var
  431. Started: DWORD;
  432. Elapsed: Integer;
  433. Later: Boolean;
  434. begin
  435. Started := GetTickCount;
  436. Later := False;
  437. while (not Later) and ProcessResult do
  438. begin
  439. Elapsed := GetTickCount - Started;
  440. Later := (Elapsed < 0) or (Elapsed > 20);
  441. end;
  442. if not Later then
  443. FTimer.Enabled := False;
  444. end;
  445. procedure TSubDirReaderThread.Timer(Sender: TObject);
  446. begin
  447. Process;
  448. end;
  449. procedure TSubDirReaderThread.Add(Node: TTreeNode; Path: string);
  450. var
  451. NodeData: TNodeData;
  452. Schedule: TSubDirReaderSchedule;
  453. begin
  454. if Suspended then
  455. Resume;
  456. FSection.Enter;
  457. try
  458. NodeData := TNodeData(Node.Data);
  459. Assert(not Assigned(NodeData.Schedule));
  460. Schedule := TSubDirReaderSchedule.Create;
  461. Schedule.Node := Node;
  462. Schedule.Path := Path;
  463. Schedule.Deleted := False;
  464. Schedule.Processed := False;
  465. FQueue.Push(Schedule);
  466. NodeData.Schedule := Schedule;
  467. finally
  468. FSection.Leave;
  469. end;
  470. TriggerEvent;
  471. end;
  472. procedure TSubDirReaderThread.Delete(Node: TTreeNode);
  473. var
  474. NodeData: TNodeData;
  475. begin
  476. FSection.Enter;
  477. try
  478. NodeData := TNodeData(Node.Data);
  479. if Assigned(NodeData.Schedule) then
  480. begin
  481. NodeData.Schedule.Deleted := True;
  482. NodeData.Schedule := nil;
  483. end;
  484. finally
  485. FSection.Leave;
  486. end;
  487. TriggerEvent;
  488. end;
  489. function TSubDirReaderThread.DetachList(List: TEnumerable<TSubDirReaderSchedule>): Integer;
  490. var
  491. Schedule: TSubDirReaderSchedule;
  492. begin
  493. Result := 0;
  494. for Schedule in List do
  495. begin
  496. if Schedule.Deleted then Schedule.Free
  497. else
  498. begin
  499. Assert(Schedule.Processed = (List = FResults));
  500. Schedule.Node := nil;
  501. Inc(Result);
  502. end;
  503. end;
  504. end;
  505. function TSubDirReaderThread.Detach: Integer;
  506. begin
  507. // block thread while handle is being recreated
  508. FSection.Enter;
  509. try
  510. Result :=
  511. DetachList(FQueue) +
  512. DetachList(FResults);
  513. FQueue.Clear;
  514. FResults.Clear;
  515. except
  516. FSection.Leave;
  517. raise;
  518. end;
  519. end;
  520. procedure TSubDirReaderThread.Reattach(Count: Integer);
  521. var
  522. Node: TTreeNode;
  523. Schedule: TSubDirReaderSchedule;
  524. begin
  525. try
  526. if Count > 0 then
  527. begin
  528. Node := FDriveView.Items.GetFirstNode;
  529. while Assigned(Node) do
  530. begin
  531. Schedule := TNodeData(Node.Data).Schedule;
  532. if Assigned(Schedule) then
  533. begin
  534. Assert(not Assigned(Schedule.Node));
  535. Schedule.Node := Node;
  536. if not Schedule.Processed then
  537. FQueue.Push(Schedule)
  538. else
  539. FResults.Enqueue(Schedule);
  540. Assert(Count > 0);
  541. // Can be optimized to stop once Count = 0
  542. Dec(Count);
  543. end;
  544. Node := Node.GetNext;
  545. end;
  546. if Count <> 0 then Assert(False); // shut up
  547. end;
  548. finally
  549. FSection.Leave;
  550. end;
  551. TriggerEvent;
  552. ScheduleProcess;
  553. end;
  554. procedure TSubDirReaderThread.Terminate;
  555. begin
  556. inherited;
  557. TriggerEvent;
  558. end;
  559. procedure TSubDirReaderThread.TriggerEvent;
  560. begin
  561. SetEvent(FEvent);
  562. end;
  563. function TSubDirReaderThread.ProcessResult: Boolean;
  564. var
  565. Node: TTreeNode;
  566. NodeData: TNodeData;
  567. Schedule: TSubDirReaderSchedule;
  568. begin
  569. FSection.Enter;
  570. try
  571. Result := (FResults.Count > 0);
  572. if Result then
  573. begin
  574. Schedule := FResults.Dequeue;
  575. if not Schedule.Deleted then
  576. begin
  577. Assert(Schedule.Processed);
  578. Node := Schedule.Node;
  579. Node.HasChildren := False;
  580. NodeData := TNodeData(Node.Data);
  581. NodeData.Scanned := not Node.HasChildren; // = True
  582. Assert(NodeData.Schedule = Schedule);
  583. NodeData.Schedule := nil;
  584. end;
  585. Schedule.Free;
  586. end;
  587. finally
  588. FSection.Leave;
  589. end;
  590. end;
  591. procedure TSubDirReaderThread.ScheduleProcess;
  592. begin
  593. // process the first batch immediatelly, to make it more likely that the first seen subdirectories
  594. // will immediatelly show correct status
  595. Process;
  596. FTimer.Enabled := True;
  597. end;
  598. procedure TSubDirReaderThread.Execute;
  599. var
  600. SRec: TSearchRec;
  601. HasSubDirs: Boolean;
  602. NodeData: TNodeData;
  603. Schedule: TSubDirReaderSchedule;
  604. DelayStart, DelayStartStep: Integer;
  605. begin
  606. DelayStart := 3000;
  607. DelayStartStep := 100;
  608. while (DelayStart > 0) and (not Terminated) do
  609. begin
  610. Sleep(DelayStartStep);
  611. Dec(DelayStart, DelayStartStep)
  612. end;
  613. while not Terminated do
  614. begin
  615. WaitForSingleObject(FEvent, INFINITE);
  616. while not Terminated do
  617. begin
  618. FSection.Enter;
  619. try
  620. if FQueue.Count = 0 then
  621. begin
  622. Break;
  623. end
  624. else
  625. begin
  626. Schedule := FQueue.Pop;
  627. if Schedule.Deleted then
  628. begin
  629. Schedule.Free;
  630. // Can be optimized to loop within locked critical section until first non-deleted schedule is found
  631. Continue;
  632. end;
  633. Assert(not Schedule.Processed);
  634. end
  635. finally
  636. FSection.Leave;
  637. end;
  638. HasSubDirs := FDriveView.FindFirstSubDir(IncludeTrailingBackslash(Schedule.Path) + '*.*', SRec);
  639. FindClose(SRec);
  640. FSection.Enter;
  641. try
  642. if Schedule.Deleted then
  643. begin
  644. Schedule.Free;
  645. end
  646. else
  647. begin
  648. Schedule.Processed := True;
  649. if not HasSubDirs then // optimization
  650. begin
  651. FResults.Enqueue(Schedule);
  652. if FResults.Count = 1 then
  653. PostMessage(FWindowHandle, WM_USER_SUBDIRREADER, 0, 0);
  654. end
  655. else
  656. begin
  657. // can happen only if the tree handle is just being recreated
  658. if Assigned(Schedule.Node) then
  659. begin
  660. NodeData := TNodeData(Schedule.Node.Data);
  661. NodeData.Schedule := nil;
  662. end;
  663. Schedule.Free;
  664. end;
  665. end;
  666. finally
  667. FSection.Leave;
  668. end;
  669. end;
  670. end;
  671. end;
  672. // TDriveTreeNode
  673. // Not sure if this is ever used (possibly only when "assigning" tree view to another instance, what never do).
  674. // It is NOT used when recreating a tree view handle - for that a node is serialized and deserialized,
  675. // including a pointer to TNodeData. See csRecreating condition in TDriveView.Delete.
  676. procedure TDriveTreeNode.Assign(Source: TPersistent);
  677. var
  678. SourceData: TNodeData;
  679. NewData: TNodeData;
  680. begin
  681. Assert(False);
  682. inherited Assign(Source);
  683. if not Deleting and (Source is TTreeNode) then
  684. begin
  685. SourceData := TNodeData(TTreeNode(Source).Data);
  686. NewData := TNodeData.Create();
  687. NewData.DirName := SourceData.DirName;
  688. NewData.Attr := SourceData.Attr;
  689. NewData.Scanned := SourceData.Scanned;
  690. NewData.Data := SourceData.Data;
  691. NewData.FIsRecycleBin := SourceData.FIsRecycleBin;
  692. NewData.IconEmpty := SourceData.IconEmpty;
  693. TTreeNode(Source).Data := NewData;
  694. end;
  695. end;
  696. // TDriveView
  697. constructor TDriveView.Create(AOwner: TComponent);
  698. var
  699. Drive: TRealDrive;
  700. begin
  701. inherited;
  702. FCreating := True;
  703. FDriveStatus := TObjectDictionary<string, TDriveStatus>.Create([doOwnsValues]);
  704. FChangeInterval := MSecsPerSec;
  705. for Drive := FirstDrive to LastDrive do
  706. begin
  707. FDriveStatus.Add(Drive, CreateDriveStatus);
  708. end;
  709. FFileOperator := TFileOperator.Create(Self);
  710. FSubDirReaderThread := TSubDirReaderThread.Create(Self);
  711. FDelayedNodes := TStringList.Create;
  712. FDelayedNodeTimer := TTimer.Create(Self);
  713. UpdateDelayedNodeTimer;
  714. FDelayedNodeTimer.Interval := 250;
  715. FDelayedNodeTimer.OnTimer := DelayedNodeTimer;
  716. FChangeFlag := False;
  717. FLastDir := EmptyStr;
  718. FValidateFlag := False;
  719. FSysColorChangePending := False;
  720. FConfirmDelete := True;
  721. FDirectory := EmptyStr;
  722. FForceRename := False;
  723. FLastRenameName := '';
  724. FRenameNode := nil;
  725. FPrevSelected := nil;
  726. FPrevSelectedIndex := -1;
  727. FChangeTimerSuspended := 0;
  728. FRecreateScheduledCount := -1;
  729. FConfirmOverwrite := True;
  730. FLastPathCut := '';
  731. FStartPos.X := -1;
  732. FStartPos.Y := -1;
  733. FDragPos := FStartPos;
  734. DriveInfo.AddHandler(DriveNotification);
  735. FDragDropFilesEx.ShellExtensions.DragDropHandler := True;
  736. end; // Create
  737. destructor TDriveView.Destroy;
  738. var
  739. DriveStatusPair: TDriveStatusPair;
  740. begin
  741. DriveInfo.RemoveHandler(DriveNotification);
  742. for DriveStatusPair in FDriveStatus do
  743. begin
  744. var DriveStatus := DriveStatusPair.Value;
  745. if Assigned(DriveStatus.DiscMonitor) then
  746. FreeAndNil(DriveStatus.DiscMonitor);
  747. if Assigned(DriveStatus.ChangeTimer) then
  748. FreeAndNil(DriveStatus.ChangeTimer);
  749. end;
  750. FDriveStatus.Free;
  751. if Assigned(FFileOperator) then
  752. FFileOperator.Free;
  753. FSubDirReaderThread.Free;
  754. Assert(FDelayedNodes.Count = 0);
  755. FreeAndNil(FDelayedNodes);
  756. inherited Destroy;
  757. end; // Destroy
  758. function TDriveView.CreateDriveStatus: TDriveStatus;
  759. begin
  760. Result := TDriveStatus.Create;
  761. Result.Scanned := False;
  762. Result.Verified := False;
  763. Result.RootNode := nil;
  764. Result.RootNodeIndex := -1;
  765. Result.DiscMonitor := nil;
  766. Result.DefaultDir := EmptyStr;
  767. // ChangeTimer:
  768. Result.ChangeTimer := TTimer.Create(Self);
  769. Result.ChangeTimer.Interval := 0;
  770. Result.ChangeTimer.Enabled := False;
  771. Result.ChangeTimer.OnTimer := ChangeTimerOnTimer;
  772. end;
  773. procedure TDriveView.DriveRemoving(Drive: string);
  774. begin
  775. DriveRemoved(Drive);
  776. TerminateWatchThread(Drive);
  777. end;
  778. procedure TDriveView.CreateWnd;
  779. var
  780. DriveStatus: TDriveStatus;
  781. begin
  782. inherited;
  783. FDragDropFilesEx.SourceEffects := [deCopy, deMove, deLink];
  784. FDragDropFilesEx.TargetEffects := [deCopy, deMove, deLink];
  785. if FPrevSelectedIndex >= 0 then
  786. begin
  787. FPrevSelected := Items[FPrevSelectedIndex];
  788. FPrevSelectedIndex := -1;
  789. end;
  790. for DriveStatus in FDriveStatus.Values do
  791. begin
  792. if DriveStatus.RootNodeIndex >= 0 then
  793. begin
  794. DriveStatus.RootNode := Items[DriveStatus.RootNodeIndex];
  795. DriveStatus.RootNodeIndex := -1;
  796. end;
  797. end;
  798. UpdateDelayedNodeTimer;
  799. if FRecreateScheduledCount >= 0 then
  800. begin
  801. FSubDirReaderThread.Reattach(FRecreateScheduledCount);
  802. FRecreateScheduledCount := -1;
  803. end;
  804. end; // CreateWnd
  805. procedure TDriveView.DestroyWnd;
  806. var
  807. DriveStatus: TDriveStatus;
  808. I: Integer;
  809. begin
  810. FDelayedNodeTimer.Enabled := False;
  811. for I := 0 to FDelayedNodes.Count - 1 do
  812. FDelayedNodes.Objects[I] := nil;
  813. if not (csRecreating in ControlState) then
  814. begin
  815. FSubDirReaderThread.Terminate;
  816. FSubDirReaderThread.WaitFor;
  817. end
  818. else
  819. if CreateWndRestores then
  820. begin
  821. Assert(FRecreateScheduledCount < 0);
  822. // Have to use field, instead of local variable in CM_RECREATEWND handler,
  823. // as CM_RECREATEWND is not invoked, when the recreation is trigerred recursivelly from parent
  824. // control/form.
  825. FRecreateScheduledCount := FSubDirReaderThread.Detach;
  826. if Items.Count > 0 then // redundant test?
  827. begin
  828. FPrevSelectedIndex := -1;
  829. if Assigned(FPrevSelected) then
  830. begin
  831. FPrevSelectedIndex := FPrevSelected.AbsoluteIndex;
  832. FPrevSelected := nil;
  833. end;
  834. for DriveStatus in FDriveStatus.Values do
  835. begin
  836. DriveStatus.RootNodeIndex := -1;
  837. if Assigned(DriveStatus.RootNode) then
  838. begin
  839. DriveStatus.RootNodeIndex := DriveStatus.RootNode.AbsoluteIndex;
  840. DriveStatus.RootNode := nil;
  841. end;
  842. end;
  843. end;
  844. end;
  845. inherited;
  846. end;
  847. function TDriveView.NodeColor(Node: TTreeNode): TColor;
  848. begin
  849. Result := clDefaultItemColor;
  850. var NodeData := TNodeData(Node.Data);
  851. if not Node.Selected then
  852. begin
  853. // Colored display of compressed directories:
  854. if (NodeData.Attr and FILE_ATTRIBUTE_COMPRESSED) <> 0 then
  855. begin
  856. if SupportsDarkMode and DarkMode then Result := clSkyBlue
  857. else Result := clBlue;
  858. end
  859. else
  860. // Dimmed display, if hidden-atrribut set:
  861. if FDimmHiddenDirs and ((NodeData.Attr and FILE_ATTRIBUTE_HIDDEN) <> 0) then
  862. Result := clGrayText
  863. end;
  864. end;
  865. function TDriveView.GetCustomDirView: TCustomDirView;
  866. begin
  867. Result := DirView;
  868. end;
  869. procedure TDriveView.SetCustomDirView(Value: TCustomDirView);
  870. begin
  871. DirView := Value as TDirView;
  872. end;
  873. function TDriveView.NodePath(Node: TTreeNode): string;
  874. var
  875. ParentNode: TTreeNode;
  876. begin
  877. if not Assigned(Node) then
  878. raise ENodeNotAssigned.Create(Format(ErrorNodeNA, ['GetDirPath']));
  879. Result := GetDirName(Node);
  880. Node := Node.Parent;
  881. while Assigned(Node) do
  882. begin
  883. ParentNode := Node.Parent;
  884. if Assigned(ParentNode) then
  885. Result := GetDirName(Node) + '\' + Result
  886. else
  887. Result := GetDirName(Node) + Result;
  888. Node := ParentNode;
  889. end;
  890. if IsRootPath(Result) then
  891. Result := ExcludeTrailingBackslash(Result);
  892. end;
  893. // NodePathName: Returns the complete path to Node with trailing backslash on rootnodes:
  894. // C:\ ,C:\WINDOWS, C:\WINDOWS\SYSTEM
  895. function TDriveView.NodePathName(Node: TTreeNode): string;
  896. begin
  897. Result := NodePath(Node);
  898. if IsRootPath(Result) then
  899. Result := IncludeTrailingBackslash(Result);
  900. end;
  901. function TDriveView.NodeIsRecycleBin(Node: TTreeNode): Boolean;
  902. begin
  903. Result := TNodeData(Node.Data).IsRecycleBin;
  904. end;
  905. function TDriveView.NodePathExists(Node: TTreeNode): Boolean;
  906. begin
  907. Result := DirectoryExists(ApiPath(NodePathName(Node)));
  908. end;
  909. function TDriveView.CanEdit(Node: TTreeNode): Boolean;
  910. begin
  911. Result := inherited CanEdit(Node) or FForceRename;
  912. if Result then
  913. begin
  914. Result := Assigned(Node.Parent) and
  915. (not TNodeData(Node.Data).IsRecycleBin) and
  916. (not ReadOnly) and
  917. (FDragDropFilesEx.DragDetectStatus <> ddsDrag) and
  918. ((TNodeData(Node.Data).Attr and (faReadOnly or faSysFile)) = 0) and
  919. (UpperCase(Node.Text) = UpperCase(GetDirName(Node)));
  920. end;
  921. FForceRename := False;
  922. end;
  923. procedure TDriveView.Edit(const Item: TTVItem);
  924. var
  925. Node: TTreeNode;
  926. Info: string;
  927. i: Integer;
  928. begin
  929. Node := GetNodeFromHItem(Item);
  930. if (Length(Item.pszText) > 0) and (Item.pszText <> Node.Text) then
  931. begin
  932. if StrContains(coInvalidDosChars, Item.pszText) then
  933. begin
  934. Info := coInvalidDosChars;
  935. for i := Length(Info) downto 1 do
  936. System.Insert(Space, Info, i);
  937. if Length(Item.pszText) > 0 then
  938. raise EInvalidDirName.Create(SErrorInvalidName + Space + Info);
  939. Exit;
  940. end;
  941. StopWatchThread;
  942. if Assigned(DirView) then
  943. DirView.StopWatchThread;
  944. FFileOperator.Flags := FileOperatorDefaultFlags + [foNoConfirmation];
  945. FFileOperator.Operation := foRename;
  946. FFileOperator.OperandFrom.Clear;
  947. FFileOperator.OperandTo.Clear;
  948. FFileOperator.OperandFrom.Add(NodePath(Node));
  949. FFileOperator.OperandTo.Add(IncludeTrailingBackslash(NodePath(Node.Parent)) + Item.pszText);
  950. try
  951. if FFileOperator.Execute then
  952. begin
  953. Node.Text := Item.pszText;
  954. TNodeData(Node.Data).DirName := Item.pszText;
  955. SortChildren(Node.Parent, False);
  956. inherited;
  957. end
  958. else
  959. begin
  960. if FileOrDirExists(IncludeTrailingBackslash(NodePath(Node.Parent)) + Item.pszText) then
  961. Info := SErrorRenameFileExists + Item.pszText
  962. else
  963. Info := SErrorRenameFile + Item.pszText;
  964. MessageBeep(MB_ICONHAND);
  965. if MessageDlg(FormatLastOSError(Info), mtError, [mbOK, mbAbort], 0) = mrOK then
  966. begin
  967. FLastRenameName := Item.pszText;
  968. FRenameNode := Node;
  969. PostMessage(Self.Handle, WM_USER_RENAME, 0, 0);
  970. end;
  971. end;
  972. finally
  973. StartWatchThread;
  974. if Assigned(DirView) then
  975. begin
  976. DirView.Reload2;
  977. DirView.StartWatchThread;
  978. end;
  979. end;
  980. end;
  981. end; // Edit
  982. procedure TDriveView.WMUserRename(var Message: TMessage);
  983. begin
  984. if Assigned(FRenameNode) then
  985. begin
  986. FForceRename := True;
  987. TreeView_EditLabel(Handle, FRenameNode.ItemID);
  988. SetWindowText(TreeView_GetEditControl(Self.Handle), PChar(FLastRenameName));
  989. FRenameNode := nil;
  990. end;
  991. end;
  992. function TDriveView.CanExpand(Node: TTreeNode): Boolean;
  993. var
  994. SubNode: TTreeNode;
  995. Drive: string;
  996. SaveCursor: TCursor;
  997. begin
  998. Result := inherited CanExpand(Node);
  999. Drive := GetDriveToNode(Node);
  1000. if Node.HasChildren then
  1001. begin
  1002. if (not Assigned(Node.Parent)) and
  1003. (not GetDriveStatus(Drive).Scanned) and
  1004. DriveInfo.IsFixedDrive(Drive) then
  1005. begin
  1006. SubNode := Node.GetFirstChild;
  1007. if not Assigned(SubNode) then
  1008. begin
  1009. ScanDrive(Drive);
  1010. SubNode := Node.GetFirstChild;
  1011. Node.HasChildren := Assigned(SubNode);
  1012. Result := Node.HasChildren;
  1013. if not Assigned(GetDriveStatus(Drive).DiscMonitor) then
  1014. CreateWatchThread(Drive);
  1015. end;
  1016. end
  1017. else
  1018. begin
  1019. SaveCursor := Screen.Cursor;
  1020. Screen.Cursor := crHourGlass;
  1021. try
  1022. if (not TNodeData(Node.Data).Scanned) and DoScanDir(Node) then
  1023. begin
  1024. ReadSubDirs(Node);
  1025. end;
  1026. finally
  1027. Screen.Cursor := SaveCursor;
  1028. end;
  1029. end;
  1030. end;
  1031. end; // CanExpand
  1032. procedure TDriveView.GetImageIndex(Node: TTreeNode);
  1033. begin
  1034. if TNodeData(Node.Data).IconEmpty then
  1035. SetImageIndex(Node);
  1036. inherited;
  1037. end;
  1038. procedure TDriveView.Loaded;
  1039. begin
  1040. inherited;
  1041. // Create the drive nodes:
  1042. RefreshRootNodes(True);
  1043. // Set the initial directory:
  1044. if (Length(FDirectory) > 0) and DirectoryExists(ApiPath(FDirectory)) then
  1045. Directory := FDirectory;
  1046. FCreating := False;
  1047. end;
  1048. function TDriveView.CreateNode: TTreeNode;
  1049. begin
  1050. Result := TDriveTreeNode.Create(Items);
  1051. end;
  1052. procedure TDriveView.Delete(Node: TTreeNode);
  1053. var
  1054. NodeData: TNodeData;
  1055. begin
  1056. if Node = FPrevSelected then
  1057. FPrevSelected := nil;
  1058. NodeData := nil;
  1059. if Assigned(Node) and Assigned(Node.Data) then
  1060. NodeData := TNodeData(Node.Data);
  1061. Node.Data := nil;
  1062. inherited;
  1063. if Assigned(NodeData) and not (csRecreating in ControlState) then
  1064. begin
  1065. FSubDirReaderThread.Delete(Node);
  1066. if Assigned(NodeData.DelayedExclude) then
  1067. begin
  1068. CancelDelayedNode(Node);
  1069. FDelayedNodes.Delete(FDelayedNodes.IndexOfObject(Node));
  1070. UpdateDelayedNodeTimer;
  1071. end;
  1072. NodeData.Destroy;
  1073. end;
  1074. end; // OnDelete
  1075. procedure TDriveView.KeyPress(var Key: Char);
  1076. begin
  1077. inherited;
  1078. if Assigned(Selected) then
  1079. begin
  1080. if Pos(Key, coInvalidDosChars) <> 0 then
  1081. begin
  1082. Beep;
  1083. Key := #0;
  1084. end;
  1085. end;
  1086. end;
  1087. function TDriveView.CanChange(Node: TTreeNode): Boolean;
  1088. var
  1089. Path: string;
  1090. Drive: string;
  1091. begin
  1092. Result := inherited CanChange(Node);
  1093. if not Reading and not (csRecreating in ControlState) then
  1094. begin
  1095. if Result and Assigned(Node) then
  1096. begin
  1097. Path := NodePathName(Node);
  1098. if Path <> FLastDir then
  1099. begin
  1100. Drive := DriveInfo.GetDriveKey(Path);
  1101. DriveInfo.ReadDriveStatus(Drive, dsSize or dsImageIndex);
  1102. if not DriveInfo.Get(Drive).DriveReady then
  1103. begin
  1104. MessageDlg(Format(SDriveNotReady, [Drive]), mtError, [mbOK], 0);
  1105. Result := False;
  1106. end
  1107. else
  1108. try
  1109. CheckCanOpenDirectory(Path);
  1110. except
  1111. Application.HandleException(Self);
  1112. Result := False;
  1113. end;
  1114. end;
  1115. end;
  1116. if Result and (csDestroying in ComponentState) then
  1117. begin
  1118. Result := False;
  1119. end;
  1120. if Result and
  1121. (not FCanChange) and
  1122. Assigned(Node) and
  1123. Assigned(Node.Data) and
  1124. Assigned(Selected) and
  1125. Assigned(Selected.Data) then
  1126. begin
  1127. DropTarget := Node;
  1128. Result := False;
  1129. end
  1130. else
  1131. begin
  1132. DropTarget := nil;
  1133. end;
  1134. end;
  1135. end;
  1136. procedure TDriveView.Change(Node: TTreeNode);
  1137. var
  1138. Drive: string;
  1139. OldSerial: DWORD;
  1140. NewDir: string;
  1141. PrevDrive: string;
  1142. begin
  1143. if not Reading and not (csRecreating in ControlState) then
  1144. begin
  1145. if Assigned(Node) then
  1146. begin
  1147. NewDir := NodePathName(Node);
  1148. if NewDir <> FLastDir then
  1149. begin
  1150. Drive := DriveInfo.GetDriveKey(NewDir);
  1151. if Length(FLastDir) > 0 then
  1152. PrevDrive := DriveInfo.GetDriveKey(FLastDir)
  1153. else
  1154. PrevDrive := '';
  1155. FChangeFlag := True;
  1156. FLastDir := NewDir;
  1157. // Most of this is done already in CanChange and possibly redundant here
  1158. OldSerial := DriveInfo.Get(Drive).DriveSerial;
  1159. DriveInfo.ReadDriveStatus(Drive, dsSize or dsImageIndex);
  1160. if Assigned(FDirView) and (FDirView.Path <> NewDir) then
  1161. FDirView.Path := NewDir;
  1162. var DriveInfoRec := DriveInfo.Get(Drive);
  1163. if DriveInfoRec.DriveReady then
  1164. begin
  1165. if not DirectoryExists(ApiPath(NewDir)) then
  1166. begin
  1167. // Unlikely to ever happen, as CanChange already tests the directory
  1168. ValidateDirectory(GetDriveStatus(Drive).RootNode);
  1169. Exit;
  1170. end;
  1171. GetDriveStatus(Drive).DefaultDir := IncludeTrailingBackslash(NewDir);
  1172. if PrevDrive <> Drive then
  1173. begin
  1174. if (PrevDrive <> '') and
  1175. (DriveInfo.Get(PrevDrive).DriveType = DRIVE_REMOVABLE) then
  1176. begin
  1177. TerminateWatchThread(PrevDrive);
  1178. end;
  1179. // Drive serial has changed or is missing: allways reread the drive:
  1180. if (DriveInfoRec.DriveSerial <> OldSerial) or (DriveInfoRec.DriveSerial = 0) then
  1181. begin
  1182. if TNodeData(GetDriveStatus(Drive).RootNode.Data).Scanned then
  1183. ScanDrive(Drive);
  1184. end;
  1185. end;
  1186. StartWatchThread;
  1187. end
  1188. else // Drive not ready:
  1189. begin
  1190. GetDriveStatus(Drive).RootNode.DeleteChildren;
  1191. GetDriveStatus(Drive).DefaultDir := EmptyStr;
  1192. end;
  1193. end;
  1194. if (not Assigned(FPrevSelected)) or (not FPrevSelected.HasAsParent(Node)) then
  1195. Node.Expand(False);
  1196. FPrevSelected := Node;
  1197. ValidateCurrentDirectoryIfNotMonitoring;
  1198. end;
  1199. end;
  1200. inherited;
  1201. end;
  1202. procedure TDriveView.SetImageIndex(Node: TTreeNode);
  1203. var
  1204. FileInfo: TShFileInfo;
  1205. Drive, NodePath: string;
  1206. begin
  1207. if Assigned(Node) and TNodeData(Node.Data).IconEmpty then
  1208. begin
  1209. NodePath := NodePathName(Node);
  1210. Drive := DriveInfo.GetDriveKey(NodePath);
  1211. if not Assigned(Node.Parent) then
  1212. begin
  1213. var ImageIndex := DriveInfo.Get(Drive).ImageIndex;
  1214. if ImageIndex = 0 then
  1215. begin
  1216. DriveInfo.ReadDriveStatus(Drive, dsImageIndex);
  1217. Node.ImageIndex := DriveInfo.Get(Drive).ImageIndex;
  1218. end
  1219. else Node.ImageIndex := ImageIndex;
  1220. Node.SelectedIndex := Node.ImageIndex;
  1221. end
  1222. else
  1223. begin
  1224. if DriveInfo.Get(Drive).DriveType = DRIVE_REMOTE then
  1225. begin
  1226. Node.ImageIndex := StdDirIcon;
  1227. Node.SelectedIndex := StdDirSelIcon;
  1228. end
  1229. else
  1230. begin
  1231. try
  1232. SHGetFileInfo(PChar(NodePath), 0, FileInfo, SizeOf(FileInfo),
  1233. SHGFI_SYSICONINDEX or SHGFI_SMALLICON);
  1234. if (FileInfo.iIcon < Images.Count) and (FileInfo.iIcon > 0) then
  1235. begin
  1236. Node.ImageIndex := FileInfo.iIcon;
  1237. SHGetFileInfo(PChar(NodePath), 0, FileInfo, SizeOf(FileInfo),
  1238. SHGFI_SYSICONINDEX or SHGFI_SMALLICON or SHGFI_OPENICON);
  1239. Node.SelectedIndex := FileInfo.iIcon;
  1240. end
  1241. else
  1242. begin
  1243. Node.ImageIndex := StdDirIcon;
  1244. Node.SelectedIndex := StdDirSelIcon;
  1245. end;
  1246. except
  1247. Node.ImageIndex := StdDirIcon;
  1248. Node.SelectedIndex := StdDirSelIcon;
  1249. end;
  1250. end;
  1251. end;
  1252. end; // IconEmpty
  1253. TNodeData(Node.Data).IconEmpty := False;
  1254. end; // SetImageIndex
  1255. function CompareDrive(List: TStringList; Index1, Index2: Integer): Integer;
  1256. var
  1257. Drive1, Drive2: string;
  1258. RealDrive1, RealDrive2: Boolean;
  1259. begin
  1260. Drive1 := List[Index1];
  1261. Drive2 := List[Index2];
  1262. RealDrive1 := DriveInfo.IsRealDrive(Drive1);
  1263. RealDrive2 := DriveInfo.IsRealDrive(Drive2);
  1264. if RealDrive1 = RealDrive2 then
  1265. begin
  1266. Result := CompareText(Drive1, Drive2);
  1267. end
  1268. else
  1269. if RealDrive1 and (not RealDrive2) then
  1270. begin
  1271. Result := -1;
  1272. end
  1273. else
  1274. begin
  1275. Result := 1;
  1276. end;
  1277. end;
  1278. function TDriveView.GetDrives: TStrings;
  1279. var
  1280. DriveStatusPair: TDriveStatusPair;
  1281. Drives: TStringList;
  1282. begin
  1283. Drives := TStringList.Create;
  1284. // We could iterate only .Keys here, but that crashes IDE for some reason
  1285. for DriveStatusPair in FDriveStatus do
  1286. begin
  1287. Drives.Add(DriveStatusPair.Key);
  1288. end;
  1289. Drives.CustomSort(CompareDrive);
  1290. Result := Drives;
  1291. end;
  1292. procedure TDriveView.DriveRemoved(Drive: string);
  1293. var
  1294. NewDrive: Char;
  1295. begin
  1296. if (Directory <> '') and (Directory[1] = Drive) then
  1297. begin
  1298. if DriveInfo.IsRealDrive(Drive) then NewDrive := Drive[1]
  1299. else NewDrive := SystemDrive;
  1300. repeat
  1301. if NewDrive < SystemDrive then NewDrive := SystemDrive
  1302. else
  1303. if NewDrive = SystemDrive then NewDrive := LastDrive
  1304. else Dec(NewDrive);
  1305. DriveInfo.ReadDriveStatus(NewDrive, dsSize or dsImageIndex);
  1306. if NewDrive = Drive then
  1307. begin
  1308. Break;
  1309. end;
  1310. if DriveInfo.Get(NewDrive).Valid and DriveInfo.Get(NewDrive).DriveReady and Assigned(GetDriveStatus(NewDrive).RootNode) then
  1311. begin
  1312. Directory := NodePathName(GetDriveStatus(NewDrive).RootNode);
  1313. break;
  1314. end;
  1315. until False;
  1316. if not Assigned(Selected) then
  1317. begin
  1318. Directory := NodePathName(GetDriveStatus(SystemDrive).RootNode);
  1319. end;
  1320. end;
  1321. end;
  1322. procedure TDriveView.DriveNotification(Notification: TDriveNotification; Drive: string);
  1323. begin
  1324. case Notification of
  1325. dnRefresh:
  1326. RefreshRootNodes;
  1327. dnRemoving:
  1328. // Lame way to reduce rick, we modify the treee while it's being updated already.
  1329. // It might be better to post an update message to the message loop.
  1330. if WatchThreadActive(Drive) then
  1331. DriveRemoving(Drive);
  1332. end;
  1333. end;
  1334. procedure TDriveView.RefreshRootNodes(Floppy: Boolean);
  1335. var
  1336. Drives: TStrings;
  1337. NewText: string;
  1338. SaveCursor: TCursor;
  1339. WasValid: Boolean;
  1340. NodeData: TNodeData;
  1341. DriveStatus: TDriveStatus;
  1342. NextDriveNode: TTreeNode;
  1343. Index: Integer;
  1344. Drive: string;
  1345. begin
  1346. SaveCursor := Screen.Cursor;
  1347. Screen.Cursor := crHourGlass;
  1348. Drives := nil;
  1349. try
  1350. Drives := GetDrives;
  1351. NextDriveNode := nil;
  1352. for Index := Drives.Count - 1 downto 0 do
  1353. begin
  1354. Drive := Drives[Index];
  1355. DriveStatus := GetDriveStatus(Drive);
  1356. if Floppy or DriveInfo.IsFixedDrive(Drive) then
  1357. begin
  1358. WasValid := Assigned(DriveStatus.RootNode);
  1359. if DriveInfo.Get(Drive).Valid then
  1360. begin
  1361. if not WasValid then
  1362. // New drive has arrived: insert new rootnode:
  1363. begin
  1364. // Create root directory node
  1365. NodeData := TNodeData.Create;
  1366. NodeData.DirName := DriveInfo.GetDriveRoot(Drive);
  1367. if Assigned(NextDriveNode) then
  1368. DriveStatus.RootNode := Items.InsertObject(NextDriveNode, '', NodeData)
  1369. else
  1370. DriveStatus.RootNode := Items.AddObject(nil, '', NodeData);
  1371. DriveStatus.RootNode.Text := GetDisplayName(DriveStatus.RootNode);
  1372. DriveStatus.RootNode.HasChildren := True;
  1373. DriveStatus.Scanned := False;
  1374. DriveStatus.Verified := False;
  1375. end
  1376. else
  1377. if DriveStatus.RootNode.ImageIndex <> DriveInfo.Get(Drive).ImageIndex then
  1378. begin
  1379. DriveStatus.RootNode.ImageIndex := DriveInfo.Get(Drive).ImageIndex;
  1380. DriveStatus.RootNode.SelectedIndex := DriveInfo.Get(Drive).ImageIndex;
  1381. end;
  1382. if Assigned(DriveStatus.RootNode) then
  1383. begin
  1384. NewText := GetDisplayName(DriveStatus.RootNode);
  1385. if DriveStatus.RootNode.Text <> NewText then
  1386. DriveStatus.RootNode.Text := NewText;
  1387. end;
  1388. end
  1389. else
  1390. if WasValid then
  1391. // Drive has been removed => delete rootnode:
  1392. begin
  1393. DriveRemoved(Drive);
  1394. DriveStatus.Scanned := False;
  1395. DriveStatus.Verified := False;
  1396. DriveStatus.RootNode.Delete;
  1397. DriveStatus.RootNode := nil;
  1398. end;
  1399. end;
  1400. if Assigned(DriveStatus.RootNode) then
  1401. NextDriveNode := DriveStatus.RootNode;
  1402. end;
  1403. finally
  1404. Screen.Cursor := SaveCursor;
  1405. Drives.Free;
  1406. end;
  1407. end;
  1408. procedure TDriveView.AddChildNode(ParentNode: TTreeNode; ParentPath: string; SRec: TSearchRec);
  1409. var
  1410. NewNode: TTreeNode;
  1411. NodeData: TNodeData;
  1412. begin
  1413. NodeData := TNodeData.Create;
  1414. NodeData.Attr := SRec.Attr;
  1415. NodeData.DirName := SRec.Name;
  1416. NodeData.FIsRecycleBin :=
  1417. (SRec.Attr and faSysFile <> 0) and
  1418. (not Assigned(ParentNode.Parent)) and
  1419. (SameText(SRec.Name, 'RECYCLED') or
  1420. SameText(SRec.Name, 'RECYCLER') or
  1421. SameText(SRec.Name, '$RECYCLE.BIN'));
  1422. NodeData.Scanned := False;
  1423. NewNode := Self.Items.AddChildObject(ParentNode, '', NodeData);
  1424. NewNode.Text := GetDisplayName(NewNode);
  1425. NewNode.HasChildren := True;
  1426. if GetDriveTypeToNode(ParentNode) <> DRIVE_REMOTE then
  1427. FSubDirReaderThread.Add(NewNode, IncludeTrailingBackslash(ParentPath) + SRec.Name);
  1428. end;
  1429. function TDriveView.GetDriveStatus(Drive: string): TDriveStatus;
  1430. begin
  1431. if not FDriveStatus.TryGetValue(Drive, Result) then
  1432. begin
  1433. Result := CreateDriveStatus;
  1434. FDriveStatus.Add(Drive, Result);
  1435. end;
  1436. end;
  1437. function TDriveView.DoScanDir(FromNode: TTreeNode): Boolean;
  1438. begin
  1439. Result := not TNodeData(FromNode.Data).IsRecycleBin;
  1440. end;
  1441. function TDriveView.DirAttrMask: Integer;
  1442. begin
  1443. Result := faDirectory or faSysFile;
  1444. if ShowHiddenDirs then
  1445. Result := Result or faHidden;
  1446. end;
  1447. procedure TDriveView.ScanDrive(Drive: string);
  1448. begin
  1449. ValidateDirectory(FindNodeToPath(DriveInfo.GetDriveRoot(Drive)));
  1450. GetDriveStatus(Drive).Scanned := True;
  1451. GetDriveStatus(Drive).Verified := False;
  1452. end;
  1453. function ExtractFirstName(S: string): string;
  1454. var
  1455. I: Integer;
  1456. begin
  1457. I := Pos('\', S);
  1458. if I = 0 then
  1459. I := Length(S);
  1460. Result := System.Copy(S, 1, I);
  1461. end;
  1462. function TDriveView.DoSearchSubDirs(
  1463. ParentNode: TTreeNode; Path: string; Level: Integer; ExistingOnly: Boolean;
  1464. var SelectionHierarchy: TTreeNodeArray; var SelectionHierarchyHeight: Integer): TTreeNode;
  1465. var
  1466. Node: TTreeNode;
  1467. Dir: string;
  1468. begin
  1469. // Extract first directory from path:
  1470. Dir := ExtractFirstName(Path);
  1471. System.Delete(Path, 1, Length(Dir));
  1472. if Dir[Length(Dir)] = '\' then
  1473. SetLength(Dir, Pred(Length(Dir)));
  1474. // Optimization. Avoid iterating possibly thousands of nodes,
  1475. // when the node we are looking for is the selected node or its ancestor.
  1476. // This is often the case, when navigating under node that has lot of siblings.
  1477. // Typically, when navigating in user's profile folder, and there are many [thousands] other user profile folders.
  1478. if (SelectionHierarchyHeight > 0) and
  1479. // Change of selection might indicate that the tree was rebuilt meanwhile and
  1480. // the references in SelectionHierarchy might not be valid anymore
  1481. (Selected = SelectionHierarchy[SelectionHierarchyHeight - 1]) and
  1482. (Level < SelectionHierarchyHeight) and
  1483. (Uppercase(GetDirName(SelectionHierarchy[Level])) = Dir) then
  1484. begin
  1485. Result := SelectionHierarchy[Level];
  1486. end
  1487. else
  1488. begin
  1489. // Paths have diverted
  1490. SelectionHierarchyHeight := 0;
  1491. Node := ParentNode.GetFirstChild;
  1492. if (not Assigned(Node)) and (not ExistingOnly) then
  1493. begin
  1494. ValidateDirectoryEx(ParentNode, rsRecursiveExisting, True);
  1495. Node := ParentNode.GetFirstChild;
  1496. end;
  1497. Result := nil;
  1498. while (not Assigned(Result)) and Assigned(Node) do
  1499. begin
  1500. if UpperCase(GetDirName(Node)) = Dir then
  1501. begin
  1502. Result := Node;
  1503. end
  1504. else
  1505. begin
  1506. Node := ParentNode.GetNextChild(Node);
  1507. end;
  1508. end;
  1509. end;
  1510. if Assigned(Result) and (Length(Path) > 0) then
  1511. begin
  1512. Result := SearchSubDirs(Result, Path, Level + 1, ExistingOnly, SelectionHierarchy, SelectionHierarchyHeight);
  1513. end;
  1514. end;
  1515. function TDriveView.SearchSubDirs(
  1516. ParentNode: TTreeNode; Path: string; Level: Integer; ExistingOnly: Boolean;
  1517. var SelectionHierarchy: TTreeNodeArray; var SelectionHierarchyHeight: Integer): TTreeNode;
  1518. var
  1519. ParentPath, SubPath: string;
  1520. SRec: TSearchRec;
  1521. ParentNodeData: TNodeData;
  1522. begin
  1523. Result := nil;
  1524. if Length(Path) > 0 then
  1525. begin
  1526. ParentNodeData := TNodeData(ParentNode.Data);
  1527. if (not ParentNodeData.Scanned) and (not ExistingOnly) then
  1528. begin
  1529. ReadSubDirs(ParentNode);
  1530. end;
  1531. Result := DoSearchSubDirs(ParentNode, Path, Level, ExistingOnly, SelectionHierarchy, SelectionHierarchyHeight);
  1532. if (not Assigned(Result)) and (not ExistingOnly) then
  1533. begin
  1534. ParentPath := NodePath(ParentNode);
  1535. if DirectoryExists(ApiPath(IncludeTrailingBackslash(ParentPath) + Path)) then
  1536. begin
  1537. SubPath := IncludeTrailingBackslash(ParentPath) + ExcludeTrailingBackslash(ExtractFirstName(Path));
  1538. if FindFirstSubDir(SubPath, SRec) then
  1539. begin
  1540. AddChildNode(ParentNode, ParentPath, SRec);
  1541. if Assigned(ParentNodeData.DelayedExclude) then
  1542. ParentNodeData.DelayedExclude.Add(SRec.Name);
  1543. SortChildren(ParentNode, False);
  1544. FindClose(SRec);
  1545. end;
  1546. Result := DoSearchSubDirs(ParentNode, Path, Level, ExistingOnly, SelectionHierarchy, SelectionHierarchyHeight);
  1547. end;
  1548. end;
  1549. end;
  1550. end; // SearchSubDirs
  1551. function TDriveView.DoFindNodeToPath(Path: string; ExistingOnly: Boolean): TTreeNode;
  1552. var
  1553. SelectionHierarchy: TTreeNodeArray;
  1554. SelectionHierarchyHeight: Integer;
  1555. Drive: string;
  1556. P, I: Integer;
  1557. RootNode, Node: TTreeNode;
  1558. begin
  1559. Result := nil;
  1560. if Length(Path) < 3 then
  1561. Exit;
  1562. // Particularly when used by TDirView to delegate browsing to
  1563. // hidden drive view, the handle may not be created
  1564. HandleNeeded;
  1565. Drive := DriveInfo.GetDriveKey(Path);
  1566. // Likely a network drive
  1567. if (not Assigned(GetDriveStatus(Drive).RootNode)) and
  1568. // Side effect of this is drive refresh that adds the network drive to the trees
  1569. DriveInfo.Get(Drive).ValidButHiddenByDrivePolicy then
  1570. begin
  1571. // This refreshes the drives again
  1572. DriveInfo.OverrideDrivePolicy(Drive);
  1573. end;
  1574. // if not assigned now, it must be that the drive already existed in DriveInfo, but it didn't make it to this view
  1575. // (possible a network drive opened in another panel before)
  1576. if not Assigned(GetDriveStatus(Drive).RootNode) then
  1577. begin
  1578. // Refresh the view drives to add the new drive and also explorer's drive drop down.
  1579. // Overkill, as we know exactly what drive to add (so not need to check all drives)
  1580. DriveInfo.DriveRefresh;
  1581. end;
  1582. if Assigned(GetDriveStatus(Drive).RootNode) then
  1583. begin
  1584. if DriveInfo.IsRealDrive(Drive) then
  1585. begin
  1586. System.Delete(Path, 1, 3);
  1587. end
  1588. else
  1589. if IsUncPath(Path) then
  1590. begin
  1591. System.Delete(Path, 1, 2);
  1592. P := Pos('\', Path);
  1593. if P = 0 then
  1594. begin
  1595. Path := '';
  1596. end
  1597. else
  1598. begin
  1599. System.Delete(Path, 1, P);
  1600. P := Pos('\', Path);
  1601. if P = 0 then
  1602. begin
  1603. Path := '';
  1604. end
  1605. else
  1606. begin
  1607. System.Delete(Path, 1, P);
  1608. end;
  1609. end;
  1610. end
  1611. else
  1612. begin
  1613. raise EConvertError.Create(Format(ErrorInvalidDrive, [Path]))
  1614. end;
  1615. if Length(Path) > 0 then
  1616. begin
  1617. if (not GetDriveStatus(Drive).Scanned) and (not ExistingOnly) then
  1618. begin
  1619. ScanDrive(Drive);
  1620. end;
  1621. Node := Selected;
  1622. RootNode := GetDriveStatus(Drive).RootNode;
  1623. if not Assigned(Node) then
  1624. begin
  1625. SelectionHierarchyHeight := 0;
  1626. end
  1627. else
  1628. begin
  1629. SelectionHierarchyHeight := Node.Level + 1;
  1630. SetLength(SelectionHierarchy, SelectionHierarchyHeight);
  1631. for I := SelectionHierarchyHeight - 1 downto 0 do
  1632. begin
  1633. SelectionHierarchy[I] := Node;
  1634. Node := Node.Parent;
  1635. end;
  1636. Assert(Selected = SelectionHierarchy[SelectionHierarchyHeight - 1]);
  1637. // Different drive - nothing to optimize
  1638. if RootNode <> SelectionHierarchy[0] then
  1639. SelectionHierarchyHeight := 0;
  1640. end;
  1641. Result := SearchSubDirs(RootNode, UpperCase(Path), 1, ExistingOnly, SelectionHierarchy, SelectionHierarchyHeight);
  1642. end
  1643. else Result := GetDriveStatus(Drive).RootNode;
  1644. end;
  1645. end;
  1646. function TDriveView.FindNodeToPath(Path: string): TTreeNode;
  1647. begin
  1648. Result := DoFindNodeToPath(Path, False);
  1649. end;
  1650. function TDriveView.TryFindNodeToPath(Path: string): TTreeNode;
  1651. begin
  1652. Result := DoFindNodeToPath(Path, True);
  1653. end;
  1654. function TDriveView.GetSubDir(var SRec: TSearchRec): Boolean;
  1655. begin
  1656. Result := True;
  1657. while Result and
  1658. ((SRec.Name = '.' ) or
  1659. (SRec.Name = '..') or
  1660. ((SRec.Attr and faDirectory) = 0)) do
  1661. begin
  1662. if FindNext(SRec) <> 0 then
  1663. begin
  1664. Result := False;
  1665. end;
  1666. end;
  1667. end;
  1668. function TDriveView.FindFirstSubDir(Path: string; var SRec: TSearchRec): Boolean;
  1669. begin
  1670. Result := (FindFirstEx(ApiPath(Path), DirAttrMask, SRec, FIND_FIRST_EX_LARGE_FETCH_PAS, FindExSearchLimitToDirectories) = 0);
  1671. if Result then
  1672. begin
  1673. Result := GetSubDir(SRec);
  1674. if not Result then FindClose(SRec);
  1675. end;
  1676. end;
  1677. function TDriveView.FindNextSubDir(var SRec: TSearchRec): Boolean;
  1678. begin
  1679. Result := (FindNext(SRec) = 0) and GetSubDir(SRec);
  1680. end;
  1681. function TDriveView.ReadSubDirsBatch(Node: TTreeNode; var SRec: TSearchRec; CheckInterval, Limit: Integer): Boolean;
  1682. var
  1683. Start: TDateTime;
  1684. Cont: Boolean;
  1685. Path: string;
  1686. Count: Integer;
  1687. DelayedExclude: TStringList;
  1688. begin
  1689. Start := Now;
  1690. Path := NodePath(Node);
  1691. Result := True;
  1692. Count := 0;
  1693. DelayedExclude := TNodeData(Node.Data).DelayedExclude;
  1694. // At least from SetDirectory > DoFindNodeToPath and CanExpand, this is not called within BeginUpdate/EndUpdate block.
  1695. // But in any case, adding it here makes expanding (which calls CanExpand) noticeably slower, when there are lot of nodes,
  1696. // because EndUpdate triggers TVN_GETDISPINFO for all nodes in the tree.
  1697. repeat
  1698. if (not Assigned(DelayedExclude)) or
  1699. (DelayedExclude.IndexOf(SRec.Name) < 0) then
  1700. begin
  1701. AddChildNode(Node, Path, SRec);
  1702. Inc(Count);
  1703. end;
  1704. Cont := FindNextSubDir(SRec);
  1705. // There are two other directory reading loops, where this is not checked
  1706. if Cont and
  1707. ((Count mod CheckInterval) = 0) and
  1708. (Limit > 0) and
  1709. (MilliSecondsBetween(Now, Start) > Limit) then
  1710. begin
  1711. Result := False;
  1712. Cont := False;
  1713. end
  1714. until not Cont;
  1715. if Result then
  1716. FindClose(Srec);
  1717. end;
  1718. procedure TDriveView.DelayedNodeTimer(Sender: TObject);
  1719. var
  1720. Node: TTreeNode;
  1721. NodeData: TNodeData;
  1722. begin
  1723. Assert(FDelayedNodes.Count > 0);
  1724. if FDelayedNodes.Count > 0 then
  1725. begin
  1726. // Control was recreated
  1727. if not Assigned(FDelayedNodes.Objects[0]) then
  1728. begin
  1729. FDelayedNodes.Objects[0] := TryFindNodeToPath(FDelayedNodes.Strings[0]);
  1730. end;
  1731. Node := TTreeNode(FDelayedNodes.Objects[0]);
  1732. if not Assigned(Node) then
  1733. begin
  1734. FDelayedNodes.Delete(0);
  1735. end
  1736. else
  1737. begin
  1738. NodeData := TNodeData(Node.Data);
  1739. if ReadSubDirsBatch(Node, NodeData.DelayedSrec, 10, 50) then
  1740. begin
  1741. FreeAndNil(NodeData.DelayedExclude);
  1742. FDelayedNodes.Delete(0);
  1743. SortChildren(Node, False);
  1744. end;
  1745. end;
  1746. end;
  1747. UpdateDelayedNodeTimer;
  1748. end;
  1749. procedure TDriveView.UpdateDelayedNodeTimer;
  1750. begin
  1751. FDelayedNodeTimer.Enabled := HandleAllocated and (FDelayedNodes.Count > 0);
  1752. end;
  1753. procedure TDriveView.ReadSubDirs(Node: TTreeNode);
  1754. var
  1755. SRec: TSearchRec;
  1756. NodeData: TNodeData;
  1757. Path: string;
  1758. CheckInterval, Limit: Integer;
  1759. begin
  1760. NodeData := TNodeData(Node.Data);
  1761. Path := NodePath(Node);
  1762. if not FindFirstSubDir(IncludeTrailingBackslash(Path) + '*.*', SRec) then
  1763. begin
  1764. Node.HasChildren := False;
  1765. end
  1766. else
  1767. begin
  1768. CheckInterval := 100;
  1769. Limit := DriveViewLoadingTooLongLimit * 1000;
  1770. if not Showing then
  1771. begin
  1772. Limit := Limit div 10;
  1773. CheckInterval := CheckInterval div 10;
  1774. end;
  1775. if not ReadSubDirsBatch(Node, SRec, CheckInterval, Limit) then
  1776. begin
  1777. NodeData.DelayedSrec := SRec;
  1778. NodeData.DelayedExclude := TStringList.Create;
  1779. NodeData.DelayedExclude.CaseSensitive := False;
  1780. NodeData.DelayedExclude.Sorted := True;
  1781. FDelayedNodes.AddObject(Path, Node);
  1782. Assert(FDelayedNodes.Count < 20); // if more, something went likely wrong
  1783. UpdateDelayedNodeTimer;
  1784. end;
  1785. SortChildren(Node, False);
  1786. end;
  1787. NodeData.Scanned := True;
  1788. Application.ProcessMessages;
  1789. end;
  1790. procedure TDriveView.CancelDelayedNode(Node: TTreeNode);
  1791. var
  1792. NodeData: TNodeData;
  1793. begin
  1794. NodeData := TNodeData(Node.Data);
  1795. FindClose(NodeData.DelayedSrec);
  1796. FreeAndNil(NodeData.DelayedExclude);
  1797. end;
  1798. procedure TDriveView.DeleteNode(Node: TTreeNode);
  1799. var
  1800. ValidNode: TTreeNode;
  1801. begin
  1802. if Assigned(Selected) and Assigned(Node.Parent) and
  1803. ((Selected = Node) or Selected.HasAsParent(Node)) then
  1804. begin
  1805. ValidNode := Node.Parent;
  1806. while (not NodePathExists(ValidNode)) and Assigned(ValidNode.Parent) do
  1807. ValidNode := ValidNode.Parent;
  1808. Selected := ValidNode;
  1809. end;
  1810. if DropTarget = Node then
  1811. DropTarget := nil;
  1812. Node.Delete;
  1813. end;
  1814. function TDriveView.CallBackValidateDir(var Node: TTreeNode; Data: Pointer): Boolean;
  1815. var
  1816. WorkNode: TTreeNode;
  1817. DelNode: TTreeNode;
  1818. SRec: TSearchRec;
  1819. SrecList: TStringList;
  1820. SubDirList: TStringList;
  1821. R: Boolean;
  1822. Index: Integer;
  1823. NewDirFound: Boolean;
  1824. ParentDir: string;
  1825. NodeData: TNodeData;
  1826. ScanDirInfo: PScanDirInfo;
  1827. begin
  1828. Result := True;
  1829. if (not Assigned(Node)) or (not Assigned(Node.Data)) then
  1830. Exit;
  1831. NewDirFound := False;
  1832. ScanDirInfo := PScanDirInfo(Data);
  1833. // Check, if directory still exists: (but not with root directory)
  1834. if Assigned(Node.Parent) and (ScanDirInfo^.StartNode = Node) and
  1835. (not NodePathExists(Node)) then
  1836. begin
  1837. DeleteNode(Node);
  1838. Node := nil;
  1839. Exit;
  1840. end;
  1841. WorkNode := Node.GetFirstChild;
  1842. NodeData := TNodeData(Node.Data);
  1843. if NodeData.Scanned and Assigned(WorkNode) then
  1844. // if node was already scanned: check wether the existing subnodes are still alive
  1845. // and add all new subdirectories as subnodes:
  1846. begin
  1847. if DoScanDir(Node) then
  1848. begin
  1849. ParentDir := IncludeTrailingBackslash(NodePath(Node));
  1850. // Build list of existing subnodes:
  1851. SubDirList := TStringList.Create;
  1852. SubDirList.CaseSensitive := True; // We want to reflect changes in subfolder name case
  1853. while Assigned(WorkNode) do
  1854. begin
  1855. SubDirList.Add(TNodeData(WorkNode.Data).DirName);
  1856. WorkNode := Node.GetNextChild(WorkNode);
  1857. end;
  1858. // Nodes are sorted using natural sorting, while TStringList.Find uses simple sorting
  1859. SubDirList.Sort;
  1860. SRecList := TStringList.Create;
  1861. SRecList.CaseSensitive := True;
  1862. R := FindFirstSubDir(ParentDir + '*.*', SRec);
  1863. while R do
  1864. begin
  1865. SrecList.Add(Srec.Name);
  1866. if not SubDirList.Find(Srec.Name, Index) then
  1867. // Subnode does not exists: add it:
  1868. begin
  1869. AddChildNode(Node, ParentDir, SRec);
  1870. NewDirFound := True;
  1871. end;
  1872. R := FindNextSubDir(Srec);
  1873. end;
  1874. FindClose(Srec);
  1875. Sreclist.Sort;
  1876. // Remove not existing subnodes:
  1877. WorkNode := Node.GetFirstChild;
  1878. while Assigned(WorkNode) do
  1879. begin
  1880. if not Assigned(WorkNode.Data) or
  1881. not SrecList.Find(TNodeData(WorkNode.Data).DirName, Index) then
  1882. begin
  1883. DelNode := WorkNode;
  1884. WorkNode := Node.GetNextChild(WorkNode);
  1885. DeleteNode(DelNode);
  1886. end
  1887. else
  1888. begin
  1889. if (SrecList[Index] <> TNodeData(WorkNode.Data).DirName) then
  1890. begin
  1891. // Case of directory letters has changed:
  1892. TNodeData(WorkNode.Data).DirName := SrecList[Index];
  1893. WorkNode.Text := SrecList[Index];
  1894. end;
  1895. WorkNode := Node.GetNextChild(WorkNode);
  1896. end;
  1897. end;
  1898. SrecList.Free;
  1899. SubDirList.Free;
  1900. // Sort subnodes:
  1901. if NewDirFound then
  1902. SortChildren(Node, False);
  1903. end;
  1904. end
  1905. else
  1906. // Node was not already scanned:
  1907. if (ScanDirInfo^.SearchNewDirs or
  1908. NodeData.Scanned or
  1909. (Node = ScanDirInfo^.StartNode)) and
  1910. DoScanDir(Node) then
  1911. begin
  1912. ReadSubDirs(Node);
  1913. end;
  1914. end;
  1915. procedure TDriveView.RebuildTree;
  1916. var
  1917. Drive: string;
  1918. begin
  1919. for Drive in FDriveStatus.Keys do
  1920. begin
  1921. var DriveStatus := GetDriveStatus(Drive);
  1922. if Assigned(DriveStatus.RootNode) and DriveStatus.Scanned then
  1923. ValidateDirectory(DriveStatus.RootNode);
  1924. end;
  1925. end;
  1926. procedure TDriveView.ValidateCurrentDirectoryIfNotMonitoring;
  1927. begin
  1928. if Assigned(Selected) and
  1929. not Assigned(GetDriveStatus(GetDriveToNode(Selected)).DiscMonitor) then
  1930. begin
  1931. ValidateDirectory(Selected);
  1932. end;
  1933. end;
  1934. procedure TDriveView.ValidateDirectoryEx(Node: TTreeNode; Recurse: TRecursiveScan;
  1935. NewDirs: Boolean);
  1936. var
  1937. Info: PScanDirInfo;
  1938. SelDir: string;
  1939. SaveCursor: TCursor;
  1940. RestartWatchThread: Boolean;
  1941. SaveCanChange: Boolean;
  1942. CurrentPath: string;
  1943. Drive: string;
  1944. begin
  1945. if Assigned(Node) and Assigned(Node.Data) and
  1946. (not FValidateFlag) and DoScanDir(Node) then
  1947. begin
  1948. SelDir := Directory;
  1949. SaveCursor := Screen.Cursor;
  1950. if Self.Focused and (Screen.Cursor <> crHourGlass) then
  1951. Screen.Cursor := crHourGlass;
  1952. CurrentPath := NodePath(Node);
  1953. Drive := DriveInfo.GetDriveKey(CurrentPath);
  1954. if not Assigned(Node.Parent) then
  1955. GetDriveStatus(Drive).ChangeTimer.Enabled := False;
  1956. RestartWatchThread := WatchThreadActive;
  1957. try
  1958. if WatchThreadActive then
  1959. StopWatchThread;
  1960. FValidateFlag := True;
  1961. FSysColorChangePending := False;
  1962. New(Info);
  1963. Info^.StartNode := Node;
  1964. Info^.SearchNewDirs := NewDirs;
  1965. Info^.DriveType := DriveInfo.Get(Drive).DriveType;
  1966. SaveCanChange := FCanChange;
  1967. FCanChange := True;
  1968. FChangeFlag := False;
  1969. Items.BeginUpdate;
  1970. try
  1971. IterateSubTree(Node, CallBackValidateDir, Recurse, coScanStartNode, Info);
  1972. finally
  1973. Items.EndUpdate;
  1974. end;
  1975. FValidateFlag := False;
  1976. if (not Assigned(Selected)) and (Length(SelDir) > 0) then
  1977. Directory := ExtractFileDrive(SelDir);
  1978. if (SelDir <> Directory) and (not FChangeFlag) then
  1979. Change(Selected);
  1980. FCanChange := SaveCanChange;
  1981. Dispose(Info);
  1982. finally
  1983. if RestartWatchThread and FWatchDirectory and not WatchThreadActive then
  1984. StartWatchThread;
  1985. if Screen.Cursor <> SaveCursor then
  1986. Screen.Cursor := SaveCursor;
  1987. if FSysColorChangePending then
  1988. begin
  1989. FSysColorChangePending := False;
  1990. if HandleAllocated then Perform(CM_SYSCOLORCHANGE, 0, 0);
  1991. end;
  1992. end;
  1993. end;
  1994. end;
  1995. function TDriveView.GetDriveTypeToNode(Node: TTreeNode): Integer;
  1996. begin
  1997. Assert(Assigned(Node));
  1998. Result := DriveInfo.Get(GetDriveToNode(Node)).DriveType;
  1999. end;
  2000. procedure TDriveView.CreateWatchThread(Drive: string);
  2001. begin
  2002. if csDesigning in ComponentState then
  2003. Exit;
  2004. if (not Assigned(GetDriveStatus(Drive).DiscMonitor)) and
  2005. FWatchDirectory and
  2006. (DriveInfo.Get(Drive).DriveType <> DRIVE_REMOTE) then
  2007. begin
  2008. var DiscMonitor := TDiscMonitor.Create(Self);
  2009. GetDriveStatus(Drive).DiscMonitor := DiscMonitor;
  2010. DiscMonitor.ChangeDelay := msThreadChangeDelay;
  2011. DiscMonitor.SubTree := True;
  2012. DiscMonitor.Filters := [moDirName];
  2013. DiscMonitor.OnChange := ChangeDetected;
  2014. DiscMonitor.OnInvalid := ChangeInvalid;
  2015. DiscMonitor.SetDirectory(DriveInfo.GetDriveRoot(Drive));
  2016. DiscMonitor.Open;
  2017. SubscribeDriveNotifications(Drive);
  2018. end;
  2019. end;
  2020. procedure TDriveView.SetWatchDirectory(Value: Boolean);
  2021. begin
  2022. if FWatchDirectory <> Value then
  2023. begin
  2024. FWatchDirectory := Value;
  2025. if (not (csDesigning in ComponentState)) and Value then
  2026. StartAllWatchThreads
  2027. else
  2028. StopAllWatchThreads;
  2029. end;
  2030. end;
  2031. procedure TDriveView.SetDirView(Value: TDirView);
  2032. begin
  2033. if Assigned(FDirView) then
  2034. FDirView.DriveView := nil;
  2035. FDirView := Value;
  2036. if Assigned(FDirView) then
  2037. FDirView.DriveView := Self;
  2038. end;
  2039. function TDriveView.NodeWatched(Node: TTreeNode): Boolean;
  2040. var
  2041. Drive: string;
  2042. begin
  2043. Drive := GetDriveToNode(Node);
  2044. Result := WatchThreadActive(Drive);
  2045. end;
  2046. procedure TDriveView.ChangeInvalid(Sender: TObject; const Directory: string;
  2047. const ErrorStr: string);
  2048. var
  2049. Drive: string;
  2050. begin
  2051. Drive := DriveInfo.GetDriveKey((Sender as TDiscMonitor).Directories[0]);
  2052. GetDriveStatus(Drive).DiscMonitor.Close;
  2053. end;
  2054. procedure TDriveView.ChangeDetected(Sender: TObject; const Directory: string;
  2055. var SubdirsChanged: Boolean);
  2056. var
  2057. DirChanged: string;
  2058. begin
  2059. if Sender is TDiscMonitor then
  2060. begin
  2061. DirChanged := (Sender as TDiscMonitor).Directories[0];
  2062. if Length(DirChanged) > 0 then
  2063. begin
  2064. var ChangeTimer := GetDriveStatus(DriveInfo.GetDriveKey(DirChanged)).ChangeTimer;
  2065. ChangeTimer.Interval := 0;
  2066. ChangeTimer.Interval := FChangeInterval;
  2067. ChangeTimer.Enabled := True;
  2068. end;
  2069. end;
  2070. end;
  2071. procedure TDriveView.ChangeTimerOnTimer(Sender: TObject);
  2072. var
  2073. DriveStatusPair: TDriveStatusPair;
  2074. begin
  2075. if (FChangeTimerSuspended = 0) and (Sender is TTimer) then
  2076. begin
  2077. for DriveStatusPair in FDriveStatus do
  2078. begin
  2079. if DriveStatusPair.Value.ChangeTimer = Sender then
  2080. begin
  2081. // Messages are processed during ValidateDirectory, so we may detect another change while
  2082. // updating the directory. Prevent the recursion.
  2083. // But retry the update afterwards (by reenabling the timer in ChangeDetected)
  2084. SuspendChangeTimer;
  2085. try
  2086. var ChangeTimer := DriveStatusPair.Value.ChangeTimer;
  2087. ChangeTimer.Interval := 0;
  2088. ChangeTimer.Enabled := False;
  2089. if Assigned(DriveStatusPair.Value.RootNode) then
  2090. begin
  2091. // Check also collapsed (invisible) subdirectories:
  2092. ValidateDirectory(DriveStatusPair.Value.RootNode);
  2093. end;
  2094. finally
  2095. ResumeChangeTimer;
  2096. end;
  2097. end;
  2098. end;
  2099. end;
  2100. end;
  2101. procedure TDriveView.SubscribeDriveNotifications(Drive: string);
  2102. begin
  2103. // As previously, subscribe drive notification only once the drive is at least once visited.
  2104. // Shouldn't do much harm to subscribe always, but just in case.
  2105. DriveInfo.SubscribeDriveNotifications(Drive);
  2106. end;
  2107. procedure TDriveView.StartWatchThread;
  2108. var
  2109. Drive: string;
  2110. begin
  2111. if (csDesigning in ComponentState) or
  2112. not Assigned(Selected) or
  2113. not FWatchDirectory then Exit;
  2114. Drive := GetDriveToNode(Selected);
  2115. var DriveStatus := GetDriveStatus(Drive);
  2116. if not Assigned(DriveStatus.DiscMonitor) then
  2117. CreateWatchThread(Drive);
  2118. if Assigned(DriveStatus.DiscMonitor) and (not DriveStatus.DiscMonitor.Enabled) then
  2119. DriveStatus.DiscMonitor.Enabled := True;
  2120. SubscribeDriveNotifications(Drive);
  2121. end;
  2122. procedure TDriveView.StopWatchThread;
  2123. var
  2124. Drive: string;
  2125. begin
  2126. if Assigned(Selected) then
  2127. begin
  2128. Drive := GetDriveToNode(Selected);
  2129. var DriveStatus := GetDriveStatus(Drive);
  2130. if Assigned(DriveStatus.DiscMonitor) then
  2131. DriveStatus.DiscMonitor.Enabled := False;
  2132. end;
  2133. end;
  2134. procedure TDriveView.SuspendChangeTimer;
  2135. begin
  2136. Inc(FChangeTimerSuspended);
  2137. end;
  2138. procedure TDriveView.ResumeChangeTimer;
  2139. begin
  2140. Assert(FChangeTimerSuspended > 0);
  2141. Dec(FChangeTimerSuspended);
  2142. end;
  2143. procedure TDriveView.TerminateWatchThread(Drive: string);
  2144. begin
  2145. var DriveStatus := GetDriveStatus(Drive);
  2146. if Assigned(DriveStatus.DiscMonitor) then
  2147. begin
  2148. DriveStatus.DiscMonitor.Free;
  2149. DriveStatus.DiscMonitor := nil;
  2150. end;
  2151. end;
  2152. procedure TDriveView.StartAllWatchThreads;
  2153. var
  2154. DriveStatusPair: TDriveStatusPair;
  2155. Drive: string;
  2156. begin
  2157. if (csDesigning in ComponentState) or (not FWatchDirectory) then
  2158. Exit;
  2159. for DriveStatusPair in FDriveStatus do
  2160. begin
  2161. var DriveStatus := DriveStatusPair.Value;
  2162. if DriveStatus.Scanned then
  2163. begin
  2164. if not Assigned(DriveStatus.DiscMonitor) then
  2165. CreateWatchThread(DriveStatusPair.Key);
  2166. if Assigned(DriveStatus.DiscMonitor) and (not DriveStatus.DiscMonitor.Active) then
  2167. begin
  2168. DriveStatus.DiscMonitor.Open;
  2169. SubscribeDriveNotifications(DriveStatusPair.Key);
  2170. end;
  2171. end;
  2172. end;
  2173. if Assigned(Selected) then
  2174. begin
  2175. Drive := GetDriveToNode(Selected);
  2176. if not DriveInfo.IsFixedDrive(Drive) then
  2177. begin
  2178. StartWatchThread;
  2179. end;
  2180. end;
  2181. end;
  2182. procedure TDriveView.StopAllWatchThreads;
  2183. var
  2184. DriveStatusPair: TDriveStatusPair;
  2185. begin
  2186. if (csDesigning in ComponentState) or (not FWatchDirectory) then
  2187. Exit;
  2188. for DriveStatusPair in FDriveStatus do
  2189. begin
  2190. var DriveStatus := DriveStatusPair.Value;
  2191. if Assigned(DriveStatus.DiscMonitor) then
  2192. begin
  2193. DriveStatus.DiscMonitor.Close;
  2194. end;
  2195. end;
  2196. end;
  2197. function TDriveView.WatchThreadActive(Drive: string): Boolean;
  2198. begin
  2199. Result := FWatchDirectory and
  2200. Assigned(GetDriveStatus(Drive).DiscMonitor) and
  2201. GetDriveStatus(Drive).DiscMonitor.Active and
  2202. GetDriveStatus(Drive).DiscMonitor.Enabled;
  2203. end;
  2204. function TDriveView.WatchThreadActive: Boolean;
  2205. var
  2206. Drive: string;
  2207. begin
  2208. if not Assigned(Selected) then
  2209. begin
  2210. Result := False;
  2211. Exit;
  2212. end;
  2213. Drive := GetDriveToNode(Selected);
  2214. Result := WatchThreadActive(Drive);
  2215. end;
  2216. function TDriveView.FindPathNode(Path: string): TTreeNode;
  2217. var
  2218. PossiblyHiddenPath: string;
  2219. Attrs: Integer;
  2220. begin
  2221. if Assigned(FOnNeedHiddenDirectories) and
  2222. (not ShowHiddenDirs) and
  2223. DirectoryExistsFix(Path) then // do not even bother if the path does not exist
  2224. begin
  2225. PossiblyHiddenPath := ExcludeTrailingPathDelimiter(Path);
  2226. while (PossiblyHiddenPath <> '') and
  2227. (not IsRootPath(PossiblyHiddenPath)) do // Drives have hidden attribute
  2228. begin
  2229. Attrs := FileGetAttr(PossiblyHiddenPath, False);
  2230. if (Attrs and faHidden) = faHidden then
  2231. begin
  2232. if Assigned(FOnNeedHiddenDirectories) then
  2233. begin
  2234. FOnNeedHiddenDirectories(Self);
  2235. end;
  2236. Break;
  2237. end
  2238. else
  2239. begin
  2240. PossiblyHiddenPath := ExtractFileDir(PossiblyHiddenPath);
  2241. end;
  2242. end;
  2243. end;
  2244. // Find existing path or parent path of not existing path:
  2245. repeat
  2246. Result := FindNodeToPath(Path);
  2247. if not Assigned(Result) then
  2248. Path := ExtractFilePath(ExcludeTrailingBackslash(Path));
  2249. until Assigned(Result) or (Length(Path) < 3);
  2250. end;
  2251. procedure TDriveView.SetDirectory(Value: string);
  2252. begin
  2253. Value := IncludeTrailingBackslash(Value);
  2254. FDirectory := Value;
  2255. inherited;
  2256. if Assigned(Selected) and (not Assigned(Selected.Parent)) then
  2257. begin
  2258. if not GetDriveStatus(GetDriveToNode(Selected)).Scanned then
  2259. ScanDrive(GetDriveToNode(Selected));
  2260. end;
  2261. end;
  2262. function TDriveView.GetDirName(Node: TTreeNode): string;
  2263. begin
  2264. if Assigned(Node) and Assigned(Node.Data) then
  2265. Result := TNodeData(Node.Data).DirName
  2266. else
  2267. Result := '';
  2268. end;
  2269. // GetDrive: returns the drive of the Node.
  2270. function TDriveView.GetDriveToNode(Node: TTreeNode): string;
  2271. var
  2272. Path: string;
  2273. begin
  2274. if (not Assigned (Node)) or (not Assigned(Node.Data)) then
  2275. raise ENodeNotAssigned.Create(Format(ErrorNodeNA, ['GetDrive']));
  2276. Path := NodePath(Node);
  2277. Result := DriveInfo.GetDriveKey(Path);
  2278. end;
  2279. // RootNode: returns the rootnode to the Node:
  2280. function TDriveView.RootNode(Node: TTreeNode): TTreeNode;
  2281. begin
  2282. Result := Node;
  2283. if not Assigned(Node) then
  2284. raise ENodeNotAssigned.Create(Format(ErrorNodeNA, ['RootNode']));
  2285. while Assigned(Result.Parent) do
  2286. Result := Result.Parent;
  2287. end;
  2288. function TDriveView.GetDisplayName(Node: TTreeNode): string;
  2289. begin
  2290. Result := '';
  2291. if (not Assigned(Node)) or (not Assigned(Node.Data)) then
  2292. raise ENodeNotAssigned.Create(Format(ErrorNodeNA, ['GetDisplayName']));
  2293. if not Assigned(Node.Parent) then Result := DriveInfo.GetPrettyName(GetDriveToNode(Node))
  2294. else
  2295. begin
  2296. Result := GetDirName(Node);
  2297. end;
  2298. end;
  2299. procedure TDriveView.DisplayContextMenu(Node: TTreeNode; Point: TPoint);
  2300. var
  2301. Verb: string;
  2302. DirWatched: Boolean;
  2303. begin
  2304. DirWatched := NodeWatched(Node) and WatchThreadActive;
  2305. Assert(Node <> nil);
  2306. if Node <> Selected then
  2307. DropTarget := Node;
  2308. Verb := EmptyStr;
  2309. if Assigned(FOnDisplayContextMenu) then
  2310. FOnDisplayContextMenu(Self);
  2311. ShellDisplayContextMenu(FParentForm.Handle, Point, NodePathName(Node),
  2312. CanEdit(Node), Verb, False);
  2313. if Verb = shcRename then Node.EditText
  2314. else
  2315. if Verb = shcCut then
  2316. begin
  2317. ClearCutState;
  2318. FLastPathCut := NodePathName(Node);
  2319. Node.Cut := True;
  2320. end
  2321. else
  2322. if Verb = shcCopy then
  2323. begin
  2324. ClearCutState;
  2325. end
  2326. else
  2327. if Verb = shcPaste then
  2328. PasteFromClipBoard(Node);
  2329. DropTarget := nil;
  2330. if not DirWatched then
  2331. ValidateDirectory(Node);
  2332. end;
  2333. procedure TDriveView.DisplayPropertiesMenu(Node: TTreeNode);
  2334. begin
  2335. Assert(Assigned(Node));
  2336. ShellExecuteContextCommand(FParentForm.Handle, shcProperties, NodePathName(Node));
  2337. end;
  2338. procedure TDriveView.SetSelected(Node: TTreeNode);
  2339. begin
  2340. if Node <> Selected then
  2341. begin
  2342. FChangeFlag := False;
  2343. FCanChange := True;
  2344. inherited Selected := Node;
  2345. if not FChangeFlag then
  2346. Change(Selected);
  2347. end;
  2348. end;
  2349. // Called by TFileDeleteThread, when a file deletion was detected by the D&D receiving application:
  2350. procedure TDriveView.SignalDirDelete(Sender: TObject; Files: TStringList);
  2351. begin
  2352. if Files.Count > 0 then
  2353. ValidateDirectory(FindNodeToPath(Files[0]));
  2354. end;
  2355. function TDriveView.DDSourceEffects: TDropEffectSet;
  2356. begin
  2357. if not Assigned(FDragNode.Parent) then
  2358. Result := [deLink]
  2359. else
  2360. Result := [deLink, deCopy, deMove];
  2361. end;
  2362. procedure TDriveView.DDChooseEffect(KeyState: Integer; var Effect: Integer; PreferredEffect: Integer);
  2363. begin
  2364. if DropTarget = nil then Effect := DROPEFFECT_NONE
  2365. else
  2366. if (KeyState and (MK_CONTROL or MK_SHIFT) = 0) and (PreferredEffect = 0) then
  2367. begin
  2368. if FDragDrive <> '' then
  2369. begin
  2370. if FExeDrag and DriveInfo.IsFixedDrive(GetDriveToNode(DropTarget)) and DriveInfo.IsFixedDrive(FDragDrive) then
  2371. begin
  2372. Effect := DROPEFFECT_LINK;
  2373. end
  2374. else
  2375. if (Effect = DROPEFFECT_COPY) and
  2376. (SameText(FDragDrive, GetDriveToNode(DropTarget)) and
  2377. (FDragDropFilesEx.AvailableDropEffects and DROPEFFECT_MOVE <> 0)) then
  2378. begin
  2379. Effect := DROPEFFECT_MOVE;
  2380. end;
  2381. end;
  2382. end;
  2383. inherited;
  2384. end;
  2385. function TDriveView.DragCompleteFileList: Boolean;
  2386. begin
  2387. Result := (GetDriveTypeToNode(FDragNode) <> DRIVE_REMOVABLE);
  2388. end;
  2389. function TDriveView.DDExecute: TDragResult;
  2390. var
  2391. WatchThreadOK: Boolean;
  2392. DragParentPath: string;
  2393. DragPath: string;
  2394. begin
  2395. WatchThreadOK := WatchThreadActive;
  2396. Result := FDragDropFilesEx.Execute(nil);
  2397. if (Result = drMove) and (not WatchThreadOK) then
  2398. begin
  2399. DragPath := NodePathName(FDragNode);
  2400. if Assigned(FDragNode.Parent) then
  2401. DragParentPath := NodePathName(FDragNode.Parent)
  2402. else
  2403. DragParentPath := DragPath;
  2404. if Assigned(FDragNode.Parent) or (DragParentPath <> NodePathName(Selected.Parent)) then
  2405. begin
  2406. FDragNode := FindNodeToPath(DragPath);
  2407. if Assigned(FDragNode) then
  2408. begin
  2409. FDragFileList.Clear;
  2410. FDragFileList.Add(DragPath);
  2411. TFileDeleteThread.Create(FDragFileList, MaxWaitTimeOut, SignalDirDelete);
  2412. end;
  2413. end;
  2414. end;
  2415. end;
  2416. procedure TDriveView.PerformDragDropFileOperation(Node: TTreeNode; Effect: Integer);
  2417. var
  2418. Index: Integer;
  2419. SourcePath: string;
  2420. SourceParentPath: string;
  2421. SourceIsDirectory: Boolean;
  2422. SaveCursor: TCursor;
  2423. SourceNode, TargetNode: TTreeNode;
  2424. TargetPath: string;
  2425. IsRecycleBin: Boolean;
  2426. begin
  2427. TargetPath := NodePathName(Node);
  2428. IsRecycleBin := NodeIsRecycleBin(Node);
  2429. if FDragDropFilesEx.FileList.Count = 0 then
  2430. Exit;
  2431. SaveCursor := Screen.Cursor;
  2432. Screen.Cursor := crHourGlass;
  2433. SourcePath := EmptyStr;
  2434. try
  2435. if (Effect = DROPEFFECT_COPY) or (Effect = DROPEFFECT_MOVE) then
  2436. begin
  2437. StopAllWatchThreads;
  2438. if Assigned(FDirView) then
  2439. FDirView.StopWatchThread;
  2440. if Assigned(DropSourceControl) and
  2441. (DropSourceControl is TDirView) and
  2442. (DropSourceControl <> FDirView) then
  2443. begin
  2444. TDirView(DropSourceControl).StopWatchThread;
  2445. end;
  2446. if DropFiles(
  2447. DragDropFilesEx, Effect, FFileOperator, TargetPath, IsRecycleBin, ConfirmDelete, ConfirmOverwrite,
  2448. Self, OnDDFileOperation, SourcePath, SourceIsDirectory) then
  2449. begin
  2450. if Assigned(FOnDDFileOperationExecuted) then
  2451. FOnDDFileOperationExecuted(Self, Effect, SourcePath, TargetPath);
  2452. end;
  2453. ClearDragFileList(FDragDropFilesEx.FileList);
  2454. // TDirView.PerformDragDropFileOperation validates the SourcePath and that actually seems correct
  2455. SourceParentPath := ExtractFilePath(ExcludeTrailingBackslash(SourcePath));
  2456. end
  2457. else
  2458. if Effect = DROPEFFECT_LINK then
  2459. // Create Link requested:
  2460. begin
  2461. for Index := 0 to FDragDropFilesEx.FileList.Count - 1 do
  2462. begin
  2463. if not DropLink(PFDDListItem(FDragDropFilesEx.FileList[Index]), TargetPath) then
  2464. begin
  2465. DDError(DDCreateShortCutError);
  2466. end;
  2467. end;
  2468. end;
  2469. if Effect = DROPEFFECT_MOVE then
  2470. Items.BeginUpdate;
  2471. // Update source directory, if move-operation was performed:
  2472. if ((Effect = DROPEFFECT_MOVE) or IsRecycleBin) then
  2473. begin
  2474. // See comment in corresponding operation in TDirView.PerformDragDropFileOperation
  2475. SourceNode := TryFindNodeToPath(SourceParentPath);
  2476. if Assigned(SourceNode) then
  2477. ValidateDirectory(SourceNode);
  2478. end;
  2479. // Update subdirectories of target directory:
  2480. TargetNode := FindNodeToPath(TargetPath);
  2481. if Assigned(TargetNode) then
  2482. ValidateDirectory(TargetNode)
  2483. else
  2484. ValidateDirectory(GetDriveStatus(DriveInfo.GetDriveKey(TargetPath)).RootNode);
  2485. if Effect = DROPEFFECT_MOVE then
  2486. Items.EndUpdate;
  2487. // Update linked component TDirView:
  2488. if Assigned(FDirView) and (not FDirView.WatchThreadActive) then
  2489. begin
  2490. case Effect of
  2491. DROPEFFECT_COPY,
  2492. DROPEFFECT_LINK:
  2493. if (IncludeTrailingBackslash(TargetPath) = IncludeTrailingBackslash(DirView.Path)) then
  2494. FDirView.Reload2;
  2495. DROPEFFECT_MOVE:
  2496. if (IncludeTrailingBackslash(TargetPath) = IncludeTrailingBackslash(DirView.Path)) or
  2497. (IncludeTrailingBackslash(SourceParentPath) = IncludeTrailingBackslash(DirView.Path)) then
  2498. begin
  2499. if FDirView <> DropSourceControl then FDirView.Reload2;
  2500. end;
  2501. end;
  2502. end;
  2503. // Update the DropSource control, if files are moved and it is a TDirView:
  2504. if (Effect = DROPEFFECT_MOVE) and (DropSourceControl is TDirView) then
  2505. begin
  2506. TDirView(DropSourceControl).ValidateSelectedFiles;
  2507. end;
  2508. finally
  2509. FFileOperator.OperandFrom.Clear;
  2510. FFileOperator.OperandTo.Clear;
  2511. StartAllWatchThreads;
  2512. if Assigned(FDirView) and (not FDirView.WatchThreadActive) then
  2513. FDirView.StartWatchThread;
  2514. if Assigned(DropSourceControl) and (DropSourceControl is TDirView) and
  2515. (not TDirView(DropSourceControl).WatchThreadActive) then
  2516. TDirView(DropSourceControl).StartWatchThread;
  2517. Screen.Cursor := SaveCursor;
  2518. end;
  2519. end;
  2520. // Clipboard operations:
  2521. procedure TDriveView.ClearCutState;
  2522. begin
  2523. if FLastPathCut <> '' then
  2524. begin
  2525. var Node := FindNodeToPath(FLastPathCut);
  2526. if Assigned(Node) then
  2527. begin
  2528. Node.Cut := False;
  2529. end;
  2530. FLastPathCut := '';
  2531. end;
  2532. if Assigned(FDirView) and
  2533. FDirView.AnyCut then // prevent recursion
  2534. begin
  2535. FDirView.EmptyClipboard;
  2536. end;
  2537. end;
  2538. procedure TDriveView.EmptyClipboard;
  2539. begin
  2540. if Windows.OpenClipBoard(0) then
  2541. begin
  2542. Windows.EmptyClipBoard;
  2543. Windows.CloseClipBoard;
  2544. ClearCutState;
  2545. end;
  2546. end;
  2547. procedure TDriveView.EmptyClipboardIfCut;
  2548. begin
  2549. // interface for TDirView - prevent recursion
  2550. if FLastPathCut <> '' then
  2551. begin
  2552. EmptyClipboard;
  2553. end;
  2554. end;
  2555. function TDriveView.CanPasteFromClipBoard: Boolean;
  2556. begin
  2557. Result := False;
  2558. if Assigned(Selected) and Windows.OpenClipboard(0) then
  2559. begin
  2560. Result := IsClipboardFormatAvailable(CF_HDROP);
  2561. Windows.CloseClipBoard;
  2562. end;
  2563. end;
  2564. procedure TDriveView.PasteFromClipBoard(Node: TTreeNode);
  2565. var
  2566. Effect: LongInt;
  2567. begin
  2568. ClearDragFileList(FDragDropFilesEx.FileList);
  2569. if CanPasteFromClipBoard and FDragDropFilesEx.GetFromClipBoard(Effect) then
  2570. begin
  2571. PerformDragDropFileOperation(Node, Effect);
  2572. if Assigned(FOnDDExecuted) then
  2573. FOnDDExecuted(Self, Effect);
  2574. if Effect = DROPEFFECT_MOVE then
  2575. EmptyClipBoard;
  2576. end;
  2577. end;
  2578. procedure TDriveView.CMSysColorChange(var Message: TMessage);
  2579. begin
  2580. if not FValidateFlag then
  2581. begin
  2582. inherited;
  2583. end
  2584. else
  2585. begin
  2586. // Do not recreate the handle, if we are just iterating nodes, at that invalidates the node objects.
  2587. // This is not perfect, as the handle can be recreated for other reasons.
  2588. // But system color change is by far the most common case.
  2589. FSysColorChangePending := True;
  2590. end;
  2591. end;
  2592. procedure TDriveView.DirHasNoChildren(Path: string);
  2593. begin
  2594. var Node := FindNodeToPath(Path);
  2595. if Assigned(Node) and Assigned(Node.Data) and (not TNodeData(Node.Data).Scanned) then
  2596. begin
  2597. Node.HasChildren := False;
  2598. TNodeData(Node.Data).Scanned := True;
  2599. end;
  2600. end;
  2601. end.