12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181118211831184118511861187118811891190119111921193119411951196119711981199120012011202120312041205120612071208120912101211121212131214121512161217121812191220122112221223122412251226122712281229123012311232123312341235123612371238123912401241124212431244124512461247124812491250125112521253125412551256125712581259126012611262126312641265126612671268126912701271127212731274127512761277127812791280128112821283128412851286128712881289129012911292129312941295129612971298129913001301130213031304130513061307130813091310131113121313131413151316131713181319132013211322132313241325132613271328132913301331133213331334133513361337133813391340134113421343134413451346134713481349135013511352135313541355135613571358135913601361136213631364136513661367136813691370137113721373137413751376137713781379138013811382138313841385138613871388138913901391139213931394139513961397139813991400140114021403140414051406140714081409141014111412141314141415141614171418141914201421142214231424142514261427142814291430143114321433143414351436143714381439144014411442144314441445144614471448144914501451145214531454145514561457145814591460146114621463146414651466146714681469147014711472147314741475147614771478147914801481148214831484148514861487148814891490149114921493149414951496149714981499150015011502150315041505150615071508150915101511151215131514151515161517151815191520152115221523152415251526152715281529153015311532153315341535153615371538153915401541154215431544154515461547154815491550155115521553155415551556155715581559156015611562156315641565156615671568156915701571157215731574157515761577157815791580158115821583158415851586158715881589159015911592159315941595159615971598159916001601160216031604160516061607160816091610161116121613161416151616161716181619162016211622162316241625162616271628162916301631163216331634163516361637163816391640164116421643164416451646164716481649165016511652165316541655165616571658165916601661166216631664166516661667166816691670167116721673167416751676167716781679168016811682168316841685168616871688168916901691169216931694169516961697169816991700170117021703170417051706170717081709171017111712171317141715171617171718171917201721172217231724172517261727172817291730173117321733173417351736173717381739174017411742174317441745174617471748174917501751175217531754175517561757175817591760176117621763176417651766176717681769177017711772177317741775177617771778177917801781178217831784178517861787178817891790179117921793179417951796179717981799180018011802180318041805180618071808180918101811181218131814181518161817181818191820182118221823182418251826182718281829183018311832183318341835183618371838183918401841184218431844184518461847184818491850185118521853185418551856185718581859186018611862186318641865186618671868186918701871187218731874187518761877187818791880188118821883188418851886188718881889189018911892189318941895189618971898189919001901190219031904190519061907190819091910191119121913191419151916191719181919192019211922192319241925192619271928192919301931193219331934193519361937193819391940194119421943194419451946194719481949195019511952195319541955195619571958195919601961196219631964196519661967196819691970197119721973197419751976197719781979198019811982198319841985198619871988198919901991199219931994199519961997199819992000200120022003200420052006200720082009201020112012201320142015201620172018201920202021202220232024202520262027202820292030203120322033203420352036203720382039204020412042204320442045204620472048204920502051205220532054205520562057205820592060206120622063206420652066206720682069207020712072207320742075207620772078207920802081208220832084208520862087208820892090209120922093209420952096209720982099210021012102210321042105210621072108210921102111211221132114211521162117211821192120212121222123212421252126212721282129213021312132213321342135213621372138213921402141214221432144214521462147214821492150215121522153215421552156215721582159216021612162216321642165216621672168216921702171217221732174217521762177217821792180218121822183218421852186218721882189219021912192219321942195219621972198219922002201220222032204220522062207220822092210221122122213221422152216221722182219222022212222222322242225222622272228222922302231223222332234223522362237223822392240224122422243224422452246224722482249225022512252225322542255225622572258225922602261226222632264226522662267226822692270227122722273227422752276227722782279228022812282228322842285228622872288228922902291229222932294229522962297229822992300230123022303230423052306230723082309231023112312231323142315231623172318231923202321232223232324232523262327232823292330233123322333233423352336233723382339234023412342234323442345234623472348234923502351235223532354235523562357235823592360236123622363236423652366236723682369237023712372237323742375237623772378237923802381238223832384238523862387238823892390239123922393239423952396239723982399240024012402240324042405240624072408240924102411241224132414241524162417241824192420242124222423242424252426242724282429243024312432243324342435243624372438243924402441244224432444244524462447244824492450245124522453245424552456245724582459246024612462246324642465246624672468246924702471247224732474247524762477247824792480248124822483248424852486248724882489249024912492249324942495249624972498249925002501250225032504250525062507250825092510251125122513251425152516251725182519252025212522252325242525252625272528252925302531253225332534253525362537253825392540254125422543254425452546254725482549255025512552255325542555255625572558255925602561256225632564256525662567256825692570257125722573257425752576257725782579258025812582258325842585258625872588258925902591259225932594259525962597259825992600260126022603260426052606260726082609261026112612261326142615261626172618261926202621262226232624262526262627262826292630263126322633263426352636263726382639264026412642264326442645264626472648264926502651265226532654265526562657265826592660266126622663266426652666266726682669267026712672267326742675267626772678267926802681268226832684268526862687268826892690269126922693269426952696269726982699270027012702270327042705270627072708270927102711271227132714271527162717271827192720272127222723272427252726272727282729273027312732273327342735273627372738273927402741274227432744274527462747274827492750275127522753275427552756275727582759276027612762276327642765276627672768276927702771277227732774277527762777277827792780278127822783278427852786278727882789279027912792279327942795279627972798279928002801280228032804280528062807280828092810281128122813281428152816281728182819282028212822282328242825282628272828282928302831283228332834283528362837283828392840284128422843284428452846284728482849285028512852285328542855285628572858285928602861286228632864286528662867286828692870287128722873287428752876287728782879288028812882288328842885288628872888288928902891289228932894289528962897289828992900290129022903290429052906290729082909291029112912291329142915291629172918291929202921292229232924292529262927292829292930293129322933293429352936293729382939294029412942294329442945294629472948294929502951295229532954295529562957295829592960296129622963296429652966296729682969297029712972297329742975297629772978297929802981298229832984298529862987298829892990299129922993299429952996299729982999300030013002300330043005300630073008300930103011301230133014301530163017301830193020302130223023302430253026302730283029303030313032303330343035303630373038303930403041304230433044304530463047304830493050305130523053305430553056305730583059306030613062306330643065306630673068306930703071307230733074307530763077307830793080308130823083308430853086308730883089309030913092309330943095309630973098309931003101310231033104310531063107310831093110311131123113311431153116311731183119312031213122312331243125312631273128312931303131313231333134313531363137313831393140314131423143314431453146314731483149315031513152315331543155315631573158315931603161316231633164316531663167316831693170317131723173317431753176317731783179318031813182318331843185318631873188318931903191319231933194319531963197319831993200320132023203320432053206320732083209321032113212321332143215321632173218321932203221322232233224322532263227322832293230323132323233323432353236323732383239324032413242324332443245324632473248324932503251325232533254325532563257325832593260326132623263326432653266326732683269327032713272327332743275327632773278327932803281328232833284328532863287328832893290329132923293329432953296329732983299330033013302330333043305330633073308330933103311331233133314331533163317331833193320332133223323332433253326332733283329333033313332333333343335333633373338333933403341334233433344334533463347334833493350335133523353335433553356335733583359336033613362336333643365336633673368336933703371337233733374337533763377337833793380338133823383338433853386338733883389339033913392339333943395339633973398339934003401340234033404340534063407340834093410341134123413341434153416341734183419342034213422342334243425342634273428342934303431343234333434343534363437343834393440344134423443344434453446344734483449345034513452345334543455345634573458345934603461346234633464346534663467346834693470347134723473347434753476347734783479348034813482348334843485348634873488348934903491349234933494349534963497349834993500350135023503350435053506350735083509351035113512351335143515351635173518351935203521352235233524352535263527352835293530353135323533353435353536353735383539354035413542354335443545354635473548354935503551355235533554355535563557355835593560356135623563356435653566356735683569357035713572357335743575357635773578357935803581358235833584358535863587358835893590359135923593359435953596359735983599360036013602360336043605360636073608360936103611361236133614361536163617361836193620362136223623362436253626362736283629363036313632363336343635363636373638363936403641364236433644364536463647364836493650365136523653365436553656365736583659366036613662366336643665366636673668366936703671367236733674367536763677367836793680368136823683368436853686368736883689369036913692369336943695369636973698369937003701370237033704370537063707370837093710371137123713371437153716371737183719372037213722372337243725372637273728372937303731373237333734373537363737373837393740374137423743374437453746374737483749375037513752375337543755375637573758375937603761376237633764376537663767376837693770377137723773377437753776377737783779378037813782378337843785 |
- unit CustomDirView;
- interface
- {$R DirImg.res}
- {$WARN UNIT_PLATFORM OFF}
- {$WARN SYMBOL_PLATFORM OFF}
- uses
- Windows, Messages, Classes, Graphics, Controls,
- Forms, ComCtrls, ShellAPI, ComObj, ShlObj, Dialogs,
- ActiveX, CommCtrl, Extctrls, ImgList, Menus, FileCtrl,
- PIDL, BaseUtils, DragDrop, DragDropFilesEx, IEDriveInfo,
- IEListView, PathLabel, SysUtils, PasTools;
- const
- clDefaultItemColor = -(COLOR_ENDCOLORS + 1);
- WM_USER_RENAME = WM_USER + 57;
- WM_USER_INVALIDATEITEM = WM_USER + $2000 + 16;
- oiNoOverlay = $00;
- oiDirUp = $01;
- oiLink = $02;
- oiBrokenLink = $04;
- oiPartial = $08;
- oiEncrypted = $10;
- DefaultHistoryCount = 200;
- const
- DDDragStartDelay = 500000;
- DirAttrMask = SysUtils.faDirectory or SysUtils.faSysFile or SysUtils.faHidden;
- const
- _XBUTTON1 = $0001;
- _XBUTTON2 = $0002;
- type
- TStatusFileInfo = record
- FilesCount: Integer;
- SelectedCount: Integer;
- FilesSize: Int64;
- SelectedSize: Int64;
- HiddenCount: Integer;
- FilteredCount: Integer;
- end;
- type
- {Drag&Drop events:}
- TDDError = (DDCreateShortCutError, DDPathNotFoundError);
- TDDOnDragEnter = procedure(Sender: TObject; DataObj: IDataObject; grfKeyState: Longint; Point: TPoint; var dwEffect: Longint; var Accept: Boolean) of object;
- TDDOnDragLeave = procedure(Sender: TObject) of object;
- TDDOnDragOver = procedure(Sender: TObject; grfKeyState: Longint; Point: TPoint; var dwEffect: Longint) of object;
- TDDOnDrop = procedure(Sender: TObject; DataObj: IDataObject; grfKeyState: Longint; Point: TPoint; var dwEffect: Longint) of object;
- TDDOnQueryContinueDrag = procedure(Sender: TObject; FEscapePressed: BOOL; grfKeyState: Longint; var Result: HResult) of object;
- TDDOnGiveFeedback = procedure(Sender: TObject; dwEffect: Longint; var Result: HResult) of object;
- TDDOnChooseEffect = procedure(Sender: TObject; grfKeyState: Longint; var dwEffect: Longint) of object;
- TDDOnDragDetect = procedure(Sender: TObject; grfKeyState: Longint; DetectStart, Point: TPoint; DragStatus: TDragDetectStatus) of object;
- TDDOnCreateDragFileList = procedure(Sender: TObject; FileList: TFileList; var Created: Boolean) of object;
- TDDOnCreateDataObject = procedure(Sender: TObject; var DataObject: TDataObject) of object;
- TDDOnTargetHasDropHandler = procedure(Sender: TObject; Item: TListItem; var Effect: Integer; var DropHandler: Boolean) of object;
- TOnProcessDropped = procedure(Sender: TObject; grfKeyState: Longint; Point: TPoint; var dwEffect: Longint) of object;
- TDDErrorEvent = procedure(Sender: TObject; ErrorNo: TDDError) of object;
- TDDExecutedEvent = procedure(Sender: TObject; dwEffect: Longint) of object;
- TDDFileOperationEvent =
- procedure(Sender: TObject; dwEffect: LongInt; SourcePath, TargetPath: string; Paste: Boolean;
- var DoOperation: Boolean) of object;
- TDDFileOperationExecutedEvent = procedure(Sender: TObject; dwEffect: LongInt; SourcePath, TargetPath: string) of object;
- TDirViewExecFileEvent = procedure(Sender: TObject; Item: TListItem; var AllowExec: Boolean) of object;
- TMatchMaskEvent = procedure(Sender: TObject; FileName: string; Directory: Boolean; Size: Int64; Modification: TDateTime; Masks: string; var Matches: Boolean; AllowImplicitMatches: Boolean) of object;
- TDirViewGetOverlayEvent = procedure(Sender: TObject; Item: TListItem; var Indexes: Word) of object;
- TDirViewGetItemColorEvent = procedure(Sender: TObject; FileName: string; Directory: Boolean; Size: Int64; Modification: TDateTime; var Color: TColor) of object;
- TDirViewUpdateStatusBarEvent = procedure(Sender: TObject; const FileInfo: TStatusFileInfo) of object;
- TDirViewBusy = procedure(Sender: TObject; Busy: Integer; var State: Boolean) of object;
- TDirViewChangeFocusEvent = procedure(Sender: TObject; Item: TListItem) of object;
- TBusyOperation = reference to procedure;
- type
- TCustomDirView = class;
- TSelAttr = (selDontCare, selYes, selNo);
- TFileFilter = record
- Masks: string;
- Directories: Boolean;
- end;
- TDirViewNotifyEvent = procedure(Sender: TCustomDirView) of object;
- TDVGetFilterEvent = procedure(Sender: TCustomDirView; Select: Boolean;
- var Filter: TFileFilter) of object;
- TDVHistoryGoEvent = procedure(Sender: TCustomDirView; Index: Integer; var Cancel: Boolean) of object;
- TCompareCriteria = (ccTime, ccSize);
- TCompareCriterias = set of TCompareCriteria;
- // First four must match TViewStyle
- TDirViewStyle = (dvsIcon, dvsSmallIcon, dvsList, dvsReport, dvsThumbnail);
- TWMXMouse = packed record
- Msg: Cardinal;
- Keys: Word;
- Button: Word;
- Pos: TSmallPoint;
- Result: Longint
- end;
- TCustomizableDragDropFilesEx = class(TDragDropFilesEx)
- public
- function Execute(DataObject: TDataObject): TDragResult;
- end;
- TCustomDirView = class(TCustomIEListView)
- private
- FAddParentDir: Boolean;
- FDimmHiddenFiles: Boolean;
- FFormatSizeBytes: TFormatBytesStyle;
- FWantUseDragImages: Boolean;
- FDragDropFilesEx: TCustomizableDragDropFilesEx;
- FUseSystemContextMenu: Boolean;
- FOnStartLoading: TNotifyEvent;
- FOnLoaded: TNotifyEvent;
- FExeDrag: Boolean;
- FDDLinkOnExeDrag: Boolean;
- FOnDDDragEnter: TDDOnDragEnter;
- FOnDDDragLeave: TDDOnDragLeave;
- FOnDDDragOver: TDDOnDragOver;
- FOnDDDrop: TDDOnDrop;
- FOnDDQueryContinueDrag: TDDOnQueryContinueDrag;
- FOnDDGiveFeedback: TDDOnGiveFeedback;
- FOnDDChooseEffect: TDDOnChooseEffect;
- FOnDDDragDetect: TDDOnDragDetect;
- FOnDDCreateDragFileList: TDDOnCreateDragFileList;
- FOnDDProcessDropped: TOnProcessDropped;
- FOnDDError: TDDErrorEvent;
- FOnDDExecuted: TDDExecutedEvent;
- FOnDDFileOperation: TDDFileOperationEvent;
- FOnDDFileOperationExecuted: TDDFileOperationExecutedEvent;
- FOnDDEnd: TNotifyEvent;
- FOnDDCreateDataObject: TDDOnCreateDataObject;
- FOnDDTargetHasDropHandler: TDDOnTargetHasDropHandler;
- FOnExecFile: TDirViewExecFileEvent;
- FForceRename: Boolean;
- FLastDDResult: TDragResult;
- FLastRenameName: string;
- FContextMenu: Boolean;
- FDragEnabled: Boolean;
- FDragPos: TPoint;
- FStartPos: TPoint;
- FDDOwnerIsSource: Boolean;
- FAbortLoading: Boolean;
- FBackCount: Integer;
- FDontRecordPath: Boolean;
- FDragOnDriveIsMove: Boolean;
- FNotifyEnabled: Boolean;
- FDragStartTime: TFileTime;
- FHistoryPaths: TStrings;
- FOverlaySmallImages: TImageList;
- FOverlayLargeImages: TImageList;
- FThumbnailShellImages: TImageList;
- FThumbnailImages: TImageList;
- FMaxHistoryCount: Integer;
- FPathLabel: TCustomPathLabel;
- FOnUpdateStatusBar: TDirViewUpdateStatusBarEvent;
- FOnHistoryChange: TDirViewNotifyEvent;
- FOnHistoryGo: TDVHistoryGoEvent;
- FOnPathChange: TDirViewNotifyEvent;
- FShowHiddenFiles: Boolean;
- FSavedSelection: Boolean;
- FSavedSelectionFile: string;
- FSavedSelectionLastFile: string;
- FSavedNames: TStringList;
- FPendingFocusSomething: Integer;
- FOnMatchMask: TMatchMaskEvent;
- FOnGetOverlay: TDirViewGetOverlayEvent;
- FOnGetItemColor: TDirViewGetItemColorEvent;
- FMask: string;
- FNaturalOrderNumericalSorting: Boolean;
- FAlwaysSortDirectoriesByName: Boolean;
- FDarkMode: Boolean;
- FScrollOnDragOver: TListViewScrollOnDragOver;
- FStatusFileInfo: TStatusFileInfo;
- FDoubleBufferedScrollingWorkaround: Boolean;
- FOnBusy: TDirViewBusy;
- FOnChangeFocus: TDirViewChangeFocusEvent;
- FFallbackThumbnail: array[Boolean] of TBitmap;
- FFallbackThumbnailSize: TSize;
- FRecreatingWnd: Integer;
- procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY;
- procedure WMNotify(var Msg: TWMNotify); message WM_NOTIFY;
- procedure WMKeyDown(var Message: TWMKeyDown); message WM_KEYDOWN;
- procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
- procedure WMLButtonUp(var Message: TWMLButtonUp); message WM_LBUTTONUP;
- procedure WMContextMenu(var Message: TWMContextMenu); message WM_CONTEXTMENU;
- procedure WMLButtonDown(var Message: TWMLButtonDown); message WM_LBUTTONDOWN;
- procedure WMRButtonDown(var Message: TWMRButtonDown); message WM_RBUTTONDOWN;
- procedure WMXButtonUp(var Message: TWMXMouse); message WM_XBUTTONUP;
- procedure WMAppCommand(var Message: TMessage); message WM_APPCOMMAND;
- procedure CMColorChanged(var Message: TMessage); message CM_COLORCHANGED;
- procedure LVMSetExtendedListViewStyle(var Message: TMessage); message LVM_SETEXTENDEDLISTVIEWSTYLE;
- procedure CMRecreateWnd(var Message: TMessage); message CM_RECREATEWND;
- procedure CMDPIChanged(var Message: TMessage); message CM_DPICHANGED;
- procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
- procedure CNKeyDown(var Message: TWMKeyDown); message CN_KEYDOWN;
- procedure WMUserInvalidateItem(var Message: TMessage); message WM_USER_INVALIDATEITEM;
- procedure DumbCustomDrawItem(Sender: TCustomListView; Item: TListItem;
- State: TCustomDrawState; var DefaultDraw: Boolean);
- procedure DumbCustomDrawSubItem(Sender: TCustomListView;
- Item: TListItem; SubItem: Integer; State: TCustomDrawState;
- var DefaultDraw: Boolean);
- function GetFilesMarkedSize: Int64;
- function GetForwardCount: Integer;
- function GetHistoryPath(Index: Integer): string;
- function GetSelectedNamesSaved: Boolean;
- function GetDirViewStyle: TDirViewStyle;
- procedure SetDirViewStyle(Value: TDirViewStyle);
- procedure ViewStyleChanged;
- function GetTargetPopupMenu: Boolean;
- function GetUseDragImages: Boolean;
- procedure SetMaxHistoryCount(Value: Integer);
- procedure SetPathLabel(Value: TCustomPathLabel);
- procedure SetTargetPopupMenu(Value: Boolean);
- procedure WMUserRename(var Message: TMessage); message WM_User_Rename;
- protected
- FCaseSensitive: Boolean;
- FDirty: Boolean;
- FFilesSize: Int64;
- FFilesSelSize: Int64;
- FHasParentDir: Boolean;
- FIsRecycleBin: Boolean;
- FLastPath: string;
- FHistoryPath: string;
- FLoadEnabled: Boolean;
- FLoading: Boolean;
- FSelectFile: string;
- FWatchForChanges: Boolean;
- FInvalidNameChars: string;
- FDragDrive: string;
- FAnnouncedState: TObject;
- FThumbnail: Boolean;
- FEffectiveMask: string;
- procedure AddToDragFileList(FileList: TFileList; Item: TListItem); virtual;
- function CanEdit(Item: TListItem): Boolean; override;
- function CanChangeSelection(Item: TListItem; Select: Boolean): Boolean; override;
- procedure CancelEdit;
- procedure ClearItems; override;
- function GetDirOK: Boolean; virtual; abstract;
- procedure DDDragDetect(grfKeyState: Longint; DetectStart, Point: TPoint; DragStatus: TDragDetectStatus); virtual;
- procedure DDDragEnter(DataObj: IDataObject; grfKeyState: Longint; Point: TPoint; var dwEffect: longint; var Accept: Boolean);
- procedure DDDragLeave(Dummy: Integer);
- procedure DDDragOver(grfKeyState: Longint; Point: TPoint; var dwEffect: Longint; PreferredEffect: LongInt);
- procedure DDChooseEffect(grfKeyState: Integer; var dwEffect: Integer; PreferredEffect: Integer); virtual;
- procedure DDDrop(DataObj: IDataObject; grfKeyState: LongInt; Point: TPoint; var dwEffect: Longint);
- procedure DDDropHandlerSucceeded(Sender: TObject; grfKeyState: Longint; Point: TPoint; dwEffect: Longint); virtual;
- procedure DDGiveFeedback(dwEffect: Longint; var Result: HResult); virtual;
- procedure DDMenuPopup(Sender: TObject; AMenu: HMenu; DataObj: IDataObject;
- AMinCustCmd:integer; grfKeyState: Longint; pt: TPoint); virtual;
- procedure DDMenuDone(Sender: TObject; AMenu: HMenu); virtual;
- procedure DDProcessDropped(Sender: TObject; grfKeyState: Longint;
- Point: TPoint; dwEffect: Longint);
- procedure DDQueryContinueDrag(FEscapePressed: LongBool;
- grfKeyState: Longint; var Result: HResult); virtual;
- procedure DDSpecifyDropTarget(Sender: TObject; DragDropHandler: Boolean;
- Point: TPoint; var pidlFQ : PItemIDList; var Filename: string); virtual;
- procedure GetDisplayInfo(ListItem: TListItem; var DispInfo: TLVItem); virtual;
- function GetDragSourceEffects: TDropEffectSet; virtual;
- function GetPathName: string; virtual; abstract;
- function GetFilesCount: Integer; virtual;
- procedure ColClick(Column: TListColumn); override;
- procedure CreateWnd; override;
- procedure DestroyWnd; override;
- function OperateOnFocusedFile(Focused: Boolean; OnlyFocused: Boolean = False): Boolean;
- function CustomCreateFileList(Focused, OnlyFocused: Boolean;
- FullPath: Boolean; FileList: TStrings = nil; ItemObject: Boolean = False): TStrings;
- function CustomDrawItem(Item: TListItem; State: TCustomDrawState;
- Stage: TCustomDrawStage): Boolean; override;
- function CustomDrawSubItem(Item: TListItem; SubItem: Integer;
- State: TCustomDrawState; Stage: TCustomDrawStage): Boolean; override;
- procedure CustomSortItems(SortProc: Pointer);
- procedure Delete(Item: TListItem); override;
- procedure DoHistoryChange; dynamic;
- function DragCompleteFileList: Boolean; virtual;
- procedure Edit(const HItem: TLVItem); override;
- procedure EndSelectionUpdate; override;
- function DoExecFile(Item: TListItem; ForceEnter: Boolean): Boolean; virtual;
- procedure Execute(Item: TListItem; ForceEnter: Boolean); virtual;
- procedure ExecuteFile(Item: TListItem); virtual; abstract;
- procedure FocusSomething(ForceMakeVisible: Boolean); override;
- function GetIsRoot: Boolean; virtual; abstract;
- function ItemCanDrag(Item: TListItem): Boolean; virtual;
- function DoItemColor(Item: TListItem): TColor;
- function ItemColor(Item: TListItem): TColor; virtual;
- function ItemImageIndex(Item: TListItem; Cache: Boolean): Integer; virtual; abstract;
- function ItemThumbnail(Item: TListItem; Size: TSize): TBitmap; virtual;
- procedure FreeThumbnails;
- function FallbackThumbnail(Dir: Boolean; Size: TSize): TBitmap;
- procedure DrawThumbnail(Item: TListItem; DC: HDC);
- // ItemIsDirectory and ItemFullFileName is in public block
- function ItemIsRecycleBin(Item: TListItem): Boolean; virtual;
- procedure KeyDown(var Key: Word; Shift: TShiftState); override;
- procedure KeyPress(var Key: Char); override;
- procedure KeyUp(var Key: Word; Shift: TShiftState); override;
- procedure LoadFiles; virtual; abstract;
- procedure PerformItemDragDropOperation(Item: TListItem; Effect: Integer; Paste: Boolean); virtual; abstract;
- procedure ProcessChangedFiles(DirView: TCustomDirView;
- FileList: TStrings; FullPath: Boolean; ExistingOnly: Boolean;
- Criterias: TCompareCriterias);
- procedure ReloadForce(CacheIcons : Boolean);
- procedure RetryRename(NewName: string);
- procedure SetAddParentDir(Value: Boolean); virtual;
- procedure SetDimmHiddenFiles(Value: Boolean); virtual;
- procedure SetItemImageIndex(Item: TListItem; Index: Integer); virtual; abstract;
- procedure SetLoadEnabled(Enabled : Boolean); virtual;
- procedure SetMultiSelect(Value: Boolean); override;
- function GetPath: string; virtual; abstract;
- function GetValid: Boolean; override;
- procedure InternalEdit(const HItem: TLVItem); virtual; abstract;
- function ItemIsFile(Item: TListItem): Boolean; virtual; abstract;
- function ItemMatchesFilter(Item: TListItem; const Filter: TFileFilter): Boolean; virtual; abstract;
- function ItemOverlayIndexes(Item: TListItem): Word; virtual;
- function IsItemVisible(Item: TListItem): Boolean;
- procedure LimitHistorySize;
- procedure Notification(AComponent: TComponent; Operation: TOperation); override;
- procedure PathChanged; virtual;
- procedure PathChanging(Relative: Boolean);
- procedure SetPath(Value: string); virtual; abstract;
- procedure SetShowHiddenFiles(Value: Boolean); virtual;
- procedure SetFormatSizeBytes(Value: TFormatBytesStyle);
- procedure SetViewStyle(Value: TViewStyle); override;
- procedure SetWatchForChanges(Value: Boolean); virtual;
- function TargetHasDropHandler(Item: TListItem; Effect: Integer): Boolean; virtual;
- procedure UpdatePathLabel; dynamic;
- procedure UpdatePathLabelCaption; dynamic;
- function FileNameMatchesMasks(FileName: string; Directory: Boolean; Size: Int64; Modification: TDateTime; Masks: string; AllowImplicitMatches: Boolean): Boolean;
- function EnableDragOnClick: Boolean; override;
- procedure SetMask(Value: string); virtual;
- procedure SetNaturalOrderNumericalSorting(Value: Boolean);
- procedure SetAlwaysSortDirectoriesByName(Value: Boolean);
- procedure SetDarkMode(Value: Boolean);
- procedure ScrollOnDragOverBeforeUpdate(ObjectToValidate: TObject);
- procedure ScrollOnDragOverAfterUpdate;
- procedure DoHistoryGo(Index: Integer);
- procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
- procedure WMKillFocus(var Message: TWMKillFocus); message WM_KILLFOCUS;
- procedure WMThemeChanged(var Message: TMessage); message WM_THEMECHANGED;
- procedure EnsureSelectionRedrawn;
- function HiddenCount: Integer; virtual; abstract;
- function FilteredCount: Integer; virtual; abstract;
- function DoBusy(Busy: Integer): Boolean;
- function StartBusy: Boolean;
- procedure EndBusy;
- function IsBusy: Boolean;
- procedure BusyOperation(Operation: TBusyOperation);
- procedure DoDisplayPropertiesMenu;
- procedure DoExecute(Item: TListItem; ForceEnter: Boolean);
- procedure DoExecuteParentDirectory;
- procedure Load(DoFocusSomething: Boolean); virtual;
- function NeedImageList(Size: TImageListSize; Recreate: Boolean; var OverlayImages: TImageList): TImageList;
- procedure NeedImageLists(Recreate: Boolean);
- procedure FreeImageLists;
- procedure UpdateDarkMode;
- procedure DoUpdateStatusBar(Force: Boolean = False);
- procedure DoCustomDrawItem(Item: TListItem; Stage: TCustomDrawStage);
- procedure ItemCalculatedSizeUpdated(Item: TListItem; OldSize, NewSize: Int64);
- procedure SaveItemsState(var FocusedItem: string; var FocusedShown: Boolean; var ShownItemOffset: Integer);
- procedure RestoreItemsState(ItemToFocus: TListItem; FocusedShown: Boolean; ShownItemOffset: Integer); overload;
- procedure RestoreItemsState(AState: TObject); overload;
- function FindFileItemIfNotEmpty(FileName: string): TListItem;
- public
- constructor Create(AOwner: TComponent); override;
- destructor Destroy; override;
- procedure Reload(CacheIcons: Boolean); virtual;
- function CreateFocusedFileList(FullPath: Boolean; FileList: TStrings = nil): TStrings;
- function CreateFileList(Focused: Boolean; FullPath: Boolean; FileList: TStrings = nil;
- ItemObject: Boolean = False): TStrings;
- function AnyFileSelected(OnlyFocused: Boolean; FilesOnly: Boolean;
- FocusedFileOnlyWhenFocused: Boolean): Boolean;
- procedure SelectFiles(Filter: TFileFilter; Select: Boolean);
- procedure ExecuteHomeDirectory; virtual; abstract;
- procedure ExecuteParentDirectory; virtual; abstract;
- procedure ExecuteRootDirectory; virtual; abstract;
- procedure ExecuteCurrentFile();
- procedure CreateDirectory(DirName: string); virtual; abstract;
- function FindFileItem(FileName: string): TListItem;
- procedure HistoryGo(Index: Integer);
- function ItemIsDirectory(Item: TListItem): Boolean; virtual; abstract;
- function ItemIsParentDirectory(Item: TListItem): Boolean; virtual; abstract;
- function ItemFullFileName(Item: TListItem): string; virtual; abstract;
- function ItemFileName(Item: TListItem): string; virtual; abstract;
- function ItemFileSize(Item: TListItem): Int64; virtual; abstract;
- function ItemFileTime(Item: TListItem; var Precision: TDateTimePrecision): TDateTime; virtual; abstract;
- function ItemData(Item: TListItem): TObject; virtual;
- procedure SetItemCalculatedSize(Item: TListItem; Size: Int64); virtual; abstract;
- procedure ReloadDirectory; virtual; abstract;
- procedure DisplayPropertiesMenu; virtual; abstract;
- function CreateChangedFileList(DirView: TCustomDirView; FullPath: Boolean;
- ExistingOnly: Boolean; Criterias: TCompareCriterias): TStrings;
- procedure CompareFiles(DirView: TCustomDirView; ExistingOnly: Boolean;
- Criterias: TCompareCriterias); virtual;
- function GetColumnText(ListItem: TListItem; Index: Integer): string;
- procedure SaveSelection;
- procedure RestoreSelection;
- procedure DiscardSavedSelection;
- procedure SaveSelectedNames;
- procedure RestoreSelectedNames;
- procedure ContinueSession(Continue: Boolean);
- function CanPasteFromClipBoard: Boolean; dynamic;
- function PasteFromClipBoard(TargetPath: string = ''): Boolean; virtual; abstract;
- function SaveState: TObject; virtual;
- procedure RestoreState(AState: TObject); virtual;
- procedure AnnounceState(AState: TObject); virtual;
- procedure FocusByName(FileName: string);
- procedure DisplayContextMenu(Where: TPoint); virtual; abstract;
- procedure DisplayContextMenuInSitu;
- procedure UpdateStatusBar;
- procedure InvalidateItem(Item: TListItem);
- property AddParentDir: Boolean read FAddParentDir write SetAddParentDir default False;
- property DimmHiddenFiles: Boolean read FDimmHiddenFiles write SetDimmHiddenFiles default True;
- property DragDropFilesEx: TCustomizableDragDropFilesEx read FDragDropFilesEx;
- property FormatSizeBytes: TFormatBytesStyle read FFormatSizeBytes write SetFormatSizeBytes default fbNone;
- property WantUseDragImages: Boolean read FWantUseDragImages write FWantUseDragImages default False;
- property UseDragImages: Boolean read GetUseDragImages stored False;
- property FullDrag default True;
- property TargetPopupMenu: Boolean read GetTargetPopupMenu write SetTargetPopupMenu default True;
- property DDOwnerIsSource: Boolean read FDDOwnerIsSource;
- property FilesSize: Int64 read FFilesSize;
- property FilesSelSize: Int64 read FFilesSelSize;
- property FilesCount: Integer read GetFilesCount;
- property FilesMarkedSize: Int64 read GetFilesMarkedSize;
- property HasParentDir: Boolean read FHasParentDir;
- property Path: string read GetPath write SetPath;
- property PathName: string read GetPathName;
- property UseSystemContextMenu: Boolean read FUseSystemContextMenu
- write FUseSystemContextMenu default True;
- property Loading: Boolean read FLoading;
- property AbortLoading: Boolean read FAbortLoading write FAbortLoading stored False;
- property BackCount: Integer read FBackCount;
- {Enable or disable populating the item list:}
- property LoadEnabled: Boolean read FLoadEnabled write SetLoadEnabled default True;
- {Displayed data is not valid => reload required}
- property Dirty: Boolean read FDirty;
- property DirOK: Boolean read GetDirOK;
- property LastPath: string read FLastPath;
- property IsRecycleBin: Boolean read FIsRecycleBin;
- property DDLinkOnExeDrag: Boolean read FDDLinkOnExeDrag
- write FDDLinkOnExeDrag default False;
- property DragOnDriveIsMove: Boolean read FDragOnDriveIsMove write FDragOnDriveIsMove;
- property DragSourceEffects: TDropEffectSet read GetDragSourceEffects{ write FDragSourceEffects};
- property ExeDrag: Boolean read FExeDrag;
- property ForwardCount: Integer read GetForwardCount;
- property HistoryPath[Index: Integer]: string read GetHistoryPath;
- property IsRoot: Boolean read GetIsRoot;
- property LastDDResult: TDragResult read FLastDDResult;
- property SmallImages;
- property LargeImages;
- property MaxHistoryCount: Integer read FMaxHistoryCount write SetMaxHistoryCount default DefaultHistoryCount;
- property SelectedNamesSaved: Boolean read GetSelectedNamesSaved;
- {filemask, multiple filters are possible: '*.pas;*.dfm'}
- property Mask: string read FMask write SetMask;
- property NaturalOrderNumericalSorting: Boolean read FNaturalOrderNumericalSorting write SetNaturalOrderNumericalSorting;
- property AlwaysSortDirectoriesByName: Boolean read FAlwaysSortDirectoriesByName write SetAlwaysSortDirectoriesByName;
- property DarkMode: Boolean read FDarkMode write SetDarkMode;
- property DirViewStyle: TDirViewStyle read GetDirViewStyle write SetDirViewStyle;
- property OnContextPopup;
- property OnStartLoading: TNotifyEvent read FOnStartLoading write FOnStartLoading;
- property OnLoaded: TNotifyEvent read FOnLoaded write FOnLoaded;
- {The mouse has entered the component window as a target of a drag&drop operation:}
- property OnDDDragEnter: TDDOnDragEnter read FOnDDDragEnter write FOnDDDragEnter;
- {The mouse has leaved the component window as a target of a drag&drop operation:}
- property OnDDDragLeave: TDDOnDragLeave read FOnDDDragLeave write FOnDDDragLeave;
- {The mouse is dragging in the component window as a target of a drag&drop operation:}
- property OnDDDragOver: TDDOnDragOver read FOnDDDragOver write FOnDDDragOver;
- {The Drag&drop operation is about to be executed:}
- property OnDDDrop: TDDOnDrop read FOnDDDrop write FOnDDDrop;
- property OnDDQueryContinueDrag: TDDOnQueryContinueDrag
- read FOnDDQueryContinueDrag write FOnDDQueryContinueDrag;
- property OnDDGiveFeedback: TDDOnGiveFeedback
- read FOnDDGiveFeedback write FOnDDGiveFeedback;
- property OnDDChooseEffect: TDDOnChooseEffect
- read FOnDDChooseEffect write FOnDDChooseEffect;
- {A drag&drop operation is about to be initiated whith
- the components window as the source:}
- property OnDDDragDetect: TDDOnDragDetect
- read FOnDDDragDetect write FOnDDDragDetect;
- property OnDDCreateDragFileList: TDDOnCreateDragFileList
- read FOnDDCreateDragFileList write FOnDDCreateDragFileList;
- property OnDDEnd: TNotifyEvent
- read FOnDDEnd write FOnDDEnd;
- property OnDDCreateDataObject: TDDOnCreateDataObject
- read FOnDDCreateDataObject write FOnDDCreateDataObject;
- property OnDDTargetHasDropHandler: TDDOnTargetHasDropHandler
- read FOnDDTargetHasDropHandler write FOnDDTargetHasDropHandler;
- {The component window is the target of a drag&drop operation:}
- property OnDDProcessDropped: TOnProcessDropped
- read FOnDDProcessDropped write FOnDDProcessDropped;
- {An error has occurred during a drag&drop operation:}
- property OnDDError: TDDErrorEvent read FOnDDError write FOnDDError;
- {The drag&drop operation has been executed:}
- property OnDDExecuted: TDDExecutedEvent
- read FOnDDExecuted write FOnDDExecuted;
- {Event is fired just before executing the fileoperation. This event is also fired when
- files are pasted from the clipboard:}
- property OnDDFileOperation: TDDFileOperationEvent
- read FOnDDFileOperation write FOnDDFileOperation;
- {Event is fired after executing the fileoperation. This event is also fired when
- files are pasted from the clipboard:}
- property OnDDFileOperationExecuted: TDDFileOperationExecutedEvent
- read FOnDDFileOperationExecuted write FOnDDFileOperationExecuted;
- {Set AllowExec to false, if actual file should not be executed:}
- property OnExecFile: TDirViewExecFileEvent
- read FOnExecFile write FOnExecFile;
- property OnHistoryChange: TDirViewNotifyEvent read FOnHistoryChange write FOnHistoryChange;
- property OnHistoryGo: TDVHistoryGoEvent read FOnHistoryGo write FOnHistoryGo;
- property OnPathChange: TDirViewNotifyEvent read FOnPathChange write FOnPathChange;
- property OnMatchMask: TMatchMaskEvent read FOnMatchMask write FOnMatchMask;
- property OnGetOverlay: TDirViewGetOverlayEvent read FOnGetOverlay write FOnGetOverlay;
- property OnGetItemColor: TDirViewGetItemColorEvent read FOnGetItemColor write FOnGetItemColor;
- property PathLabel: TCustomPathLabel read FPathLabel write SetPathLabel;
- property ShowHiddenFiles: Boolean read FShowHiddenFiles write SetShowHiddenFiles default True;
- property OnUpdateStatusBar: TDirViewUpdateStatusBarEvent read FOnUpdateStatusBar write FOnUpdateStatusBar;
- property OnBusy: TDirViewBusy read FOnBusy write FOnBusy;
- property OnChangeFocus: TDirViewChangeFocusEvent read FOnChangeFocus write FOnChangeFocus;
- {Watch current directory for filename changes (create, rename, delete files)}
- property WatchForChanges: Boolean read FWatchForChanges write SetWatchForChanges default False;
- end;
- resourcestring
- SErrorRenameFile = 'Can''t rename file or directory: ';
- SErrorRenameFileExists = 'File already exists: ';
- SErrorInvalidName = 'Filename contains invalid characters:';
- STextFileExt = 'File %s';
- STextFiles = '%u Files';
- STextDirectories = '%u Directories';
- SParentDir = 'Parent directory';
- SDragDropError = 'DragDrop Error: %d';
- SDriveNotReady = 'Drive ''%s:'' is not ready.';
- SDirNotExists = 'Directory ''%s'' doesn''t exist.';
- {Additional non-component specific functions:}
- {Create and resolve a shell link (file shortcut):}
- function CreateFileShortCut(SourceFile, Target, DisplayName: string;
- UpdateIfExists: Boolean = False): Boolean;
- function ResolveFileShortCut(SourceFile: string; ShowDialog: Boolean = False): string;
- function IsExecutable(FileName: string): Boolean;
- function GetNextMask(var Mask: string): string;
- procedure DefaultFileFilter(var Filter: TFileFilter);
- function CompareLogicalTextPas(const S1, S2: string; NaturalOrderNumericalSorting: Boolean): Integer;
- function OverlayImageList(Size: Integer): TImageList;
- procedure InitFileControls;
- var
- StdDirIcon: Integer;
- StdDirSelIcon: Integer;
- DropSourceControl: TObject;
- UnknownFileIcon: Integer = 0;
- StdDirTypeName: string;
- DefaultExeIcon: Integer;
- UserDocumentDirectory: string;
- const
- coInvalidDosChars = '\/:*?"<>|';
- Space = ' ';
- implementation
- uses
- Math, DirViewColProperties, UITypes, Types, OperationWithTimeout, Winapi.UxTheme, Vcl.Themes, System.IOUtils;
- const
- ResDirUp = 'DIRUP%2.2d';
- ResLink = 'LINK%2.2d';
- ResBrokenLink = 'BROKEN%2.2d';
- ResPartial = 'PARTIAL%2.2d';
- ResEncrypted = 'ENCRYPTED%2.2d';
- var
- WinDir: string;
- TempDir: string;
- GlobalsInitialized: Boolean = False;
- function GetIconIndex(const AFile: string; Attrs: DWORD; Flags: UINT): Integer;
- var
- FileInfo: TSHFileInfo;
- begin
- try
- SHGetFileInfo(PChar(AFile), Attrs, FileInfo, SizeOf(TSHFileInfo),
- Flags or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES);
- Result := FileInfo.iIcon;
- except
- Result := -1;
- end;
- end; {GetIconIndex}
- function GetshFileInfo(const AFile: string; Attrs: DWORD; Flags: UINT): TSHFileInfo;
- begin
- try
- SHGetFileInfoWithTimeout(PChar(AFile), Attrs, Result, SizeOf(TSHFileInfo), Flags, 1000);
- except
- FillChar(Result, SizeOf(Result), 0);
- end;
- end; {GetshFileInfo}
- procedure InitFileControls;
- begin
- if not GlobalsInitialized then
- begin
- GlobalsInitialized := True;
- // See the comment in the call from Execute()
- NeedShellImageLists;
- // Calling GetshFileInfo in Windows Session 0 sometime cause crash
- // (not immediately, but very shortly afterwards [few ms]).
- // So this code was moved from initialization section to avoid it
- // being used for non-GUI runs.
- UnknownFileIcon := GetshFileInfo('$#)(.#$)', FILE_ATTRIBUTE_NORMAL,
- SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES).iIcon;
- DefaultExeIcon := GetshFileInfo('.COM',
- FILE_ATTRIBUTE_NORMAL, SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES).iIcon;
- with GetshFileInfo(WinDir, FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY,
- SHGFI_TYPENAME or SHGFI_SYSICONINDEX or SHGFI_USEFILEATTRIBUTES) do
- begin
- StdDirTypeName := szTypeName;
- StdDirIcon := iIcon;
- end;
- StdDirSelIcon := GetIconIndex(WinDir,
- FILE_ATTRIBUTE_NORMAL or FILE_ATTRIBUTE_DIRECTORY, SHGFI_OPENICON);
- end;
- end;
- type
- TDirViewState = class(TObject)
- public
- constructor Create;
- destructor Destroy; override;
- private
- HistoryPaths: TStrings;
- BackCount: Integer;
- SortStr: string;
- Mask: string;
- FocusedItem: string;
- FocusedShown: Boolean;
- ShownItemOffset: Integer;
- end;
- constructor TDirViewState.Create;
- begin
- inherited;
- end;
- destructor TDirViewState.Destroy;
- begin
- HistoryPaths.Free;
- inherited;
- end;
- function IsExecutable(FileName: string): Boolean;
- var
- FileExt: string;
- begin
- FileExt := UpperCase(ExtractFileExt(FileName));
- Result := (FileExt = '.EXE') or (FileExt = '.COM');
- end;
- function GetNextMask(var Mask: string): string;
- var
- NextPos: Integer;
- begin
- NextPos := Pos(';', Mask);
- if NextPos = 0 then
- begin
- Result := Mask;
- SetLength(Mask, 0);
- end
- else
- begin
- Result := Copy(Mask, 1, NextPos - 1);
- Delete(Mask, 1, NextPos);
- end;
- end;
- procedure DefaultFileFilter(var Filter: TFileFilter);
- begin
- with Filter do
- begin
- SetLength(Masks, 0);
- Directories := False;
- end;
- end;
- function StrCmpLogicalW(const sz1, sz2: UnicodeString): Integer; stdcall; external 'shlwapi.dll';
- function CompareLogicalTextPas(const S1, S2: string; NaturalOrderNumericalSorting: Boolean): Integer;
- begin
- // Keep in sync with CompareLogicalText
- if NaturalOrderNumericalSorting then
- Result := StrCmpLogicalW(PChar(S1), PChar(S2))
- else
- Result := lstrcmpi(PChar(S1), PChar(S2));
- // For deterministics results
- if Result = 0 then
- Result := lstrcmp(PChar(S1), PChar(S2));
- end;
- { Shortcut-handling }
- function ResolveFileShortCut(SourceFile: string; ShowDialog: Boolean = False): string;
- var
- IUnk: IUnknown;
- HRes: HRESULT; // OLE-Operation Result
- SL: IShellLink; // Interface for ShellLink
- PF: IPersistFile; // Interface for PersistentFile
- SRec: TWIN32FINDDATA; // SearchRec of targetfile
- TargetDir: array[1..Max_Path] of Char; // Working directory of targetfile
- Flags: DWORD;
- begin
- Result := '';
- IUnk := CreateComObject(CLSID_ShellLink);
- SL := IUnk as IShellLink;
- PF := IUnk as IPersistFile;
- HRes := PF.Load(PChar(SourceFile), STGM_READ);
- if Succeeded(Hres) then
- begin
- if not ShowDialog then Flags := SLR_NOUPDATE or (1500 shl 8) or SLR_NO_UI
- else Flags := SLR_NOUPDATE;
- HRes := SL.Resolve(Application.Handle, Flags);
- if Succeeded(HRes) then
- begin
- HRes := SL.GetPath(@TargetDir, MAX_PATH, SRec, {SLGP_UNCPRIORITY}{SLGP_SHORTPATH} 0);
- if Succeeded(HRes) then
- Result := string(PChar(@TargetDir));
- end;
- end;
- end; {ResolveShortCut}
- function CreateFileShortCut(SourceFile, Target, DisplayName: string;
- UpdateIfExists: Boolean): Boolean;
- var
- IUnk: IUnknown;
- Hres: HRESULT;
- ShellLink: IShellLink; // Interface to ShellLink
- IPFile: IPersistFile; // Interface to PersistentFile
- TargetFile: string;
- begin
- Result := False;
- if Target = '' then TargetFile := SourceFile + '.lnk'
- else TargetFile := Target;
- IUnk := CreateComObject(CLSID_ShellLink);
- ShellLink := IUnk as IShellLink;
- IPFile := IUnk as IPersistFile;
- if FileExists(ApiPath(TargetFile)) and UpdateIfExists then
- begin
- HRes := IPFile.Load(PChar(TargetFile), 0);
- if not Succeeded(HRes) then Exit;
- end;
- with ShellLink do
- begin
- HRes := SetPath(PChar(SourceFile));
- if Succeeded(HRes) then
- HRes := SetWorkingDirectory(PChar(ExtractFilePath(SourceFile)));
- if Succeeded(HRes) and (DisplayName <> '') then
- HRes := SetDescription(PChar(DisplayName));
- end;
- if Succeeded(Hres) then
- begin
- HRes := IPFile.Save(PChar(TargetFile),False);
- if Succeeded(HRes) then Result := True;
- end;
- end; {CreateShortCut}
- function OverlayImageList(Size: Integer): TImageList;
- procedure GetOverlayBitmap(ImageList: TImageList; BitmapName: string);
- var
- Bitmap: TBitmap;
- begin
- Bitmap := TBitmap.Create;
- try
- Bitmap.LoadFromResourceName(hInstance, BitmapName);
- ImageList.AddMasked(Bitmap, Bitmap.Canvas.Pixels[0, 0]);
- finally
- Bitmap.Free;
- end;
- end; {GetOverlayBitmap}
- begin
- // Hardcoded according to sizes of overlays we have in resources
- if Size >= 64 then Size := 64
- else
- if Size >= 48 then Size := 48
- else
- if Size >= 40 then Size := 40
- else
- if Size >= 32 then Size := 32
- else
- if Size >= 24 then Size := 24
- else
- if Size >= 20 then Size := 20
- else Size := 16;
- Result := TImageList.CreateSize(Size, Size);
- Result.DrawingStyle := dsTransparent;
- Result.BkColor := clNone;
- GetOverlayBitmap(Result, Format(ResDirUp, [Size]));
- GetOverlayBitmap(Result, Format(ResLink, [Size]));
- GetOverlayBitmap(Result, Format(ResBrokenLink, [Size]));
- GetOverlayBitmap(Result, Format(ResPartial, [Size]));
- GetOverlayBitmap(Result, Format(ResEncrypted, [Size]));
- end;
- { TCustomizableDragDropFilesEx }
- function TCustomizableDragDropFilesEx.Execute(DataObject: TDataObject): TDragResult;
- begin
- if not Assigned(DataObject) then
- begin
- DataObject := CreateDataObject;
- end;
- Result := ExecuteOperation(DataObject);
- end;
- { TCustomDirView }
- constructor TCustomDirView.Create(AOwner: TComponent);
- begin
- InitFileControls;
- inherited;
- FWatchForChanges := False;
- FFilesSize := 0;
- FFilesSelSize := 0;
- FDimmHiddenFiles := True;
- FShowHiddenFiles := True;
- FFormatSizeBytes := fbNone;
- FWantUseDragImages := False;
- FAddParentDir := False;
- FullDrag := True;
- FInvalidNameChars := coInvalidDosChars;
- FHasParentDir := False;
- FDragOnDriveIsMove := False;
- FCaseSensitive := False;
- FIsRecycleBin := False;
- FLoading := False;
- FLoadEnabled := True;
- FAbortLoading := False;
- FDirty := False;
- FLastPath := '';
- FHistoryPath := '';
- FNotifyEnabled := True;
- FForceRename := False;
- FLastRenameName := '';
- FSavedSelection := False;
- FPendingFocusSomething := -1;
- FSavedNames := TStringList.Create;
- FContextMenu := False;
- FUseSystemContextMenu := True;
- FStartPos.X := -1;
- FStartPos.Y := -1;
- FDragPos := FStartPos;
- FDragEnabled := False;
- FDDOwnerIsSource := False;
- FDDLinkOnExeDrag := False;
- FDragDrive := '';
- FExeDrag := False;
- FMask := '';
- FNaturalOrderNumericalSorting := True;
- FAlwaysSortDirectoriesByName := False;
- FDarkMode := False;
- FDoubleBufferedScrollingWorkaround := not IsVistaHard();
- FOnHistoryChange := nil;
- FOnPathChange := nil;
- FHistoryPaths := TStringList.Create;
- FBackCount := 0;
- FDontRecordPath := False;
- FMaxHistoryCount := DefaultHistoryCount;
- FStatusFileInfo.FilesCount := -1;
- OnCustomDrawItem := DumbCustomDrawItem;
- OnCustomDrawSubItem := DumbCustomDrawSubItem;
- FOnMatchMask := nil;
- FOnGetOverlay := nil;
- FOnGetItemColor := nil;
- FDragDropFilesEx := TCustomizableDragDropFilesEx.Create(Self);
- with FDragDropFilesEx do
- begin
- AutoDetectDnD := False;
- DragDetectDelta := 4;
- AcceptOwnDnD := True;
- BringToFront := True;
- CompleteFileList := True;
- NeedValid := [nvFileName];
- RenderDataOn := rdoEnterAndDropSync;
- TargetPopUpMenu := True;
- SourceEffects := DragSourceEffects;
- TargetEffects := [deCopy, deMove];
- OnDragEnter := DDDragEnter;
- OnDragLeave := DDDragLeave;
- OnDragOver := DDDragOver;
- OnDrop := DDDrop;
- OnQueryContinueDrag := DDQueryContinueDrag;
- OnSpecifyDropTarget := DDSpecifyDropTarget;
- OnMenuPopup := DDMenuPopup;
- OnMenuDestroy := DDMenuDone;
- OnDropHandlerSucceeded := DDDropHandlerSucceeded;
- OnGiveFeedback := DDGiveFeedback;
- OnProcessDropped := DDProcessDropped;
- OnDragDetect := DDDragDetect;
- end;
- FScrollOnDragOver := TListViewScrollOnDragOver.Create(Self, False);
- FScrollOnDragOver.OnBeforeUpdate := ScrollOnDragOverBeforeUpdate;
- FScrollOnDragOver.OnAfterUpdate := ScrollOnDragOverAfterUpdate;
- end;
- procedure TCustomDirView.ClearItems;
- begin
- CancelEdit;
- if Assigned(DropTarget) then DropTarget := nil;
- try
- inherited;
- finally
- FFilesSelSize := 0;
- FFilesSize := 0;
- DoUpdateStatusBar;
- end;
- end;
- procedure TCustomDirView.WMNotify(var Msg: TWMNotify);
- begin
- // This all is to make header text white in dark mode.
- if Msg.NMHdr.code = NM_CUSTOMDRAW then
- begin
- if DarkMode and SupportsDarkMode and
- GetSysDarkTheme and // When system app theme is light, headers are not dark
- (FHeaderHandle <> 0) and (Msg.NMHdr^.hWndFrom = FHeaderHandle) then
- begin
- with PNMLVCustomDraw(Msg.NMHdr)^ do
- begin
- if nmcd.dwDrawStage = CDDS_PREPAINT then
- begin
- inherited;
- Msg.Result := Msg.Result or CDRF_NOTIFYITEMDRAW;
- end
- else
- if nmcd.dwDrawStage = CDDS_ITEMPREPAINT then
- begin
- SetTextColor(nmcd.hdc, ColorToRGB(Font.Color));
- Msg.Result := CDRF_DODEFAULT;
- inherited;
- end
- else inherited;
- end;
- end
- else inherited;
- end
- else inherited;
- end;
- procedure TCustomDirView.DrawThumbnail(Item: TListItem; DC: HDC);
- var
- Rect: TRect;
- Thumbnail: TBitmap;
- Size: TSize;
- Left, Top: Integer;
- BlendFunction: TBlendFunction;
- ThumbnailDC: HDC;
- begin
- Rect := Item.DisplayRect(drIcon);
- // For thumbnails: The larger side (e.g. height for portrait oriented images) is rescaled to Size.Width
- // For icons: The "generated" images is exactly as requested
- Size.Height := MulDiv(Min(Rect.Width, Rect.Height), 9, 10);
- Size.Width := Size.Height;
- Thumbnail := ItemThumbnail(Item, Size);
- if not Assigned(Thumbnail) then
- Thumbnail := FallbackThumbnail(ItemIsDirectory(Item), Size);
- if Assigned(Thumbnail) then
- begin
- Left := Rect.Left + ((Rect.Width - Thumbnail.Width) div 2);
- Top := Rect.Bottom - Thumbnail.Height - MulDiv(Rect.Height, 1, 20); // Bottom-aligned, as Explorer does
- // https://stackoverflow.com/q/24595717/850848
- // https://stackoverflow.com/q/10028531/850848#10044325
- ThumbnailDC := CreateCompatibleDC(0);
- try
- SelectObject(ThumbnailDC, Thumbnail.Handle);
- BlendFunction.BlendOp := AC_SRC_OVER;
- BlendFunction.BlendFlags := 0;
- BlendFunction.SourceConstantAlpha := 255;
- BlendFunction.AlphaFormat := AC_SRC_ALPHA;
- AlphaBlend(DC, Left, Top, Thumbnail.Width, Thumbnail.Height, ThumbnailDC, 0, 0, Thumbnail.Width, Thumbnail.Height, BlendFunction);
- finally
- DeleteDC(ThumbnailDC);
- end;
- end;
- end;
- procedure TCustomDirView.CNNotify(var Message: TWMNotify);
- procedure DrawOverlayImage(DC: HDC; Image: Integer; Item: TListItem);
- var
- OverlayImages: TCustomImageList;
- Rect: TRect;
- Point: TPoint;
- Index: Integer;
- begin
- Rect := Item.DisplayRect(drIcon);
- Point := Rect.TopLeft;
- if ViewStyle = vsIcon then
- begin
- OverlayImages := FOverlayLargeImages;
- end
- else
- begin
- OverlayImages := FOverlaySmallImages;
- end;
- // center on the rect
- Inc(Point.X, (Rect.Width - OverlayImages.Width) div 2);
- Inc(Point.Y, (Rect.Height - OverlayImages.Height) div 2);
- Index := 0;
- while Image > 1 do
- begin
- Inc(Index);
- Image := Image shr 1;
- end;
- if (ViewStyle <> vsReport) or
- (8 + OverlayImages.Width <= Columns[0].Width) then
- begin
- ImageList_Draw(OverlayImages.Handle, Index, DC, Point.X, Point.Y, ILD_TRANSPARENT);
- end;
- end;
- var
- FileSize: Int64;
- Item: TListItem;
- InfoMask: LongWord;
- OverlayIndex: Word;
- OverlayIndexes: Word;
- UpdateStatusBarPending: Boolean;
- Nmcd: PNMCustomDraw;
- begin
- UpdateStatusBarPending := False;
- case Message.NMHdr^.code of
- LVN_ITEMCHANGED:
- with PNMListView(Message.NMHdr)^ do
- if (uChanged = LVIF_STATE) and Valid and (not FClearingItems) then
- begin
- if ((uOldState and (LVIS_SELECTED or LVIS_FOCUSED)) <> (uNewState and (LVIS_SELECTED or LVIS_FOCUSED))) then
- begin
- Item := Items[iItem];
- UpdateStatusBarPending := True;
- if (uOldState and LVIS_SELECTED) <> (uNewState and LVIS_SELECTED) then
- begin
- FileSize := ItemFileSize(Item);
- if (uOldState and LVIS_SELECTED) <> 0 then Dec(FFilesSelSize, FileSize)
- else Inc(FFilesSelSize, FileSize);
- end;
- if (uOldState and LVIS_FOCUSED) <> (uNewState and LVIS_FOCUSED) then
- begin
- if Assigned(OnChangeFocus) then
- OnChangeFocus(Self, Item);
- end;
- end;
- end;
- LVN_ENDLABELEDIT:
- // enable loading now only when editing was canceled.
- // when it was confirmed, it will be enabled only after actual
- // file renaming is completed. see Edit().
- with PLVDispInfo(Message.NMHdr)^ do
- if (item.pszText = nil) or (item.IItem = -1) then
- LoadEnabled := True;
- LVN_BEGINDRAG:
- if FDragEnabled and (not Loading) then
- begin
- DDBeforeDrag;
- DDDragDetect(MK_LBUTTON, FStartPos, Mouse.CursorPos, ddsDrag);
- end;
- LVN_BEGINRDRAG:
- if FDragEnabled and (not Loading) then
- begin
- DDBeforeDrag;
- DDDragDetect(MK_RBUTTON, FStartPos, Mouse.CursorPos, ddsDrag);
- end;
- end;
- inherited;
- if Message.NMHdr.code = LVN_GETDISPINFO then
- begin
- if FNotifyEnabled and Valid and (not Loading) then
- with PLVDispInfo(Pointer(Message.NMHdr))^.Item do
- try
- InfoMask := PLVDispInfo(Pointer(Message.NMHdr))^.item.Mask;
- if (InfoMask and LVIF_PARAM) <> 0 then Item := TListItem(lParam)
- else
- if iItem < Items.Count then Item := Items[iItem]
- else Item := nil;
- if Assigned(Item) and Assigned(Item.Data) then
- GetDisplayInfo(Item, PLVDispInfo(Pointer(Message.NMHdr))^.item);
- except
- end;
- end;
- if (Message.NMHdr.code = NM_CUSTOMDRAW) and Valid and (not Loading) then
- begin
- Nmcd := @PNMLVCustomDraw(Message.NMHdr).nmcd;
- try
- if (Nmcd.dwDrawStage and CDDS_SUBITEM) = 0 then
- begin
- if (Nmcd.dwDrawStage and CDDS_ITEMPREPAINT) = CDDS_ITEMPREPAINT then
- begin
- Message.Result := Message.Result or CDRF_NOTIFYPOSTPAINT;
- end
- else
- if ((Nmcd.dwDrawStage and CDDS_ITEMPOSTPAINT) = CDDS_ITEMPOSTPAINT) and
- (Nmcd.rc.Width > 0) then // We get called many times with empty rect while view is recreating (e.g. when switching to thumnails mode)
- begin
- Item := Items[Nmcd.dwItemSpec];
- if IsItemVisible(Item) then // particularly the thumbnail drawing is expensive
- begin
- if FThumbnail then
- begin
- DrawThumbnail(Item, Nmcd.hdc);
- end
- else
- begin
- OverlayIndexes := ItemOverlayIndexes(Item);
- OverlayIndex := 1;
- while OverlayIndexes > 0 do
- begin
- if (OverlayIndex and OverlayIndexes) <> 0 then
- begin
- DrawOverlayImage(Nmcd.hdc, OverlayIndex, Item);
- Dec(OverlayIndexes, OverlayIndex);
- end;
- OverlayIndex := OverlayIndex shl 1;
- end;
- end;
- end;
- end;
- end;
- except
- end;
- end;
- if UpdateStatusBarPending then DoUpdateStatusBar;
- end;
- function TCustomDirView.FileNameMatchesMasks(FileName: string;
- Directory: Boolean; Size: Int64; Modification: TDateTime; Masks: string;
- AllowImplicitMatches: Boolean): Boolean;
- begin
- Result := False;
- if Assigned(OnMatchMask) then
- OnMatchMask(Self, FileName, Directory, Size, Modification, Masks, Result, AllowImplicitMatches)
- end;
- procedure TCustomDirView.SetAddParentDir(Value: Boolean);
- begin
- if FAddParentDir <> Value then
- begin
- FAddParentDir := Value;
- if DirOK then Reload(True);
- end;
- end;
- procedure TCustomDirView.SetDimmHiddenFiles(Value: Boolean);
- begin
- if Value <> FDimmHiddenFiles then
- begin
- FDimmHiddenFiles := Value;
- Self.Repaint;
- end;
- end; {SetDimmHiddenFiles}
- procedure TCustomDirView.SetPathLabel(Value: TCustomPathLabel);
- begin
- if FPathLabel <> Value then
- begin
- if Assigned(FPathLabel) and (FPathLabel.FocusControl = Self) then
- FPathLabel.FocusControl := nil;
- FPathLabel := Value;
- if Assigned(Value) then
- begin
- Value.FreeNotification(Self);
- if not Assigned(Value.FocusControl) then
- Value.FocusControl := Self;
- UpdatePathLabel;
- end;
- end;
- end; { SetPathLabel }
- procedure TCustomDirView.SetShowHiddenFiles(Value: Boolean);
- begin
- if ShowHiddenFiles <> Value then
- begin
- FShowHiddenFiles := Value;
- if DirOK then Reload(False);
- end;
- end;
- procedure TCustomDirView.SetFormatSizeBytes(Value: TFormatBytesStyle);
- begin
- if Value <> FFormatSizeBytes then
- begin
- FFormatSizeBytes := Value;
- Self.Repaint;
- end;
- end; {SetFormatSizeBytes}
- function TCustomDirView.GetDragSourceEffects: TDropEffectSet;
- begin
- Result := [deCopy, deMove, deLink];
- end;
- function TCustomDirView.GetUseDragImages: Boolean;
- begin
- Result := FWantUseDragImages;
- end;
- procedure TCustomDirView.SetTargetPopupMenu(Value: Boolean);
- begin
- if Assigned(FDragDropFilesEx) then FDragDropFilesEx.TargetPopupMenu := Value;
- end;
- function TCustomDirView.NeedImageList(Size: TImageListSize; Recreate: Boolean; var OverlayImages: TImageList): TImageList;
- begin
- Result := ShellImageListForControl(Self, Size);
- if (not Assigned(OverlayImages)) or Recreate then
- begin
- FreeAndNil(OverlayImages);
- OverlayImages := OverlayImageList(Result.Width);
- end;
- end;
- procedure TCustomDirView.NeedImageLists(Recreate: Boolean);
- var
- ALargeImages: TImageList;
- ThumbnailSize: Integer;
- begin
- SmallImages := NeedImageList(ilsSmall, Recreate, FOverlaySmallImages);
- ALargeImages := NeedImageList(ilsLarge, Recreate, FOverlayLargeImages);
- if FThumbnail then
- begin
- ThumbnailSize := ScaleByPixelsPerInch(128, Self);
- // ShellImageListForSize would normally prefer smaller icons (for row sizing purposes).
- // But for thumbnails, we prefer larger version as will will scale it when painting.
- // The *2 is hackish way to achieve that.
- FThumbnailShellImages := ShellImageListForSize(ThumbnailSize * 2);
- if (not Assigned(FThumbnailImages)) or (FThumbnailImages.Width <> ThumbnailSize) then
- begin
- if Assigned(FThumbnailImages) then
- FreeAndNil(FThumbnailImages);
- // Dummy image list, whose sole purpose it to autosize the items in the view
- FThumbnailImages := TImageList.CreateSize(ThumbnailSize, ThumbnailSize);
- end;
- LargeImages := FThumbnailImages
- end
- else LargeImages := ALargeImages;
- end;
- procedure TCustomDirView.CMDPIChanged(var Message: TMessage);
- begin
- inherited;
- NeedImageLists(True);
- end;
- const
- RequiredStyles = LVS_EX_DOUBLEBUFFER or LVS_EX_TRANSPARENTBKGND;
- procedure TCustomDirView.CMEnabledChanged(var Message: TMessage);
- var
- ListViewStyle: DWORD;
- begin
- inherited;
- // We need this so that we can control background color of disabled file panel for dark theme.
- // See comment in LVMSetExtendedListViewStyle for an explanation.
- ListViewStyle := ListView_GetExtendedListViewStyle(Handle);
- if Enabled then
- begin
- ListView_SetExtendedListViewStyle(Handle, (ListViewStyle or RequiredStyles));
- end
- else
- begin
- ListView_SetExtendedListViewStyle(Handle, (ListViewStyle and (not RequiredStyles)));
- end;
- end;
- procedure TCustomDirView.FreeImageLists;
- begin
- FreeAndNil(FOverlaySmallImages);
- FreeAndNil(FOverlayLargeImages);
- FreeAndNil(FThumbnailImages);
- SmallImages := nil;
- LargeImages := nil;
- end;
- procedure TCustomDirView.WMThemeChanged(var Message: TMessage);
- begin
- if SupportsDarkMode then // To reduce impact
- begin
- UpdateDarkMode;
- RedrawWindow(Handle, nil, 0, RDW_FRAME or RDW_INVALIDATE);
- end;
- inherited;
- end;
- procedure TCustomDirView.UpdateDarkMode;
- begin
- if SupportsDarkMode then // To reduce impact
- begin
- AllowDarkModeForWindow(Self, DarkMode);
- if FHeaderHandle <> 0 then
- begin
- AllowDarkModeForWindow(FHeaderHandle, DarkMode);
- SendMessage(FHeaderHandle, WM_THEMECHANGED, 0, 0);
- end;
- end;
- end;
- procedure TCustomDirView.CreateWnd;
- begin
- inherited;
- if Assigned(PopupMenu) then
- PopupMenu.Autopopup := False;
- FDragDropFilesEx.DragDropControl := Self;
- if SupportsDarkMode then
- begin
- // This enables dark mode - List view itself supports dark mode somewhat even in the our 'Explorer' theme.
- // The 'ItemsView' has better (Explorer-like) dark mode selection color, but on the other hand it does not have dark scrollbars.
- // win32-darkmode has ugly fix for that (FixDarkScrollBar), which we do not want to employ.
- // The 'DarkMode_Explorer' uses the standard selection color (bright blue).
- // Enables dark headers:
- SetWindowTheme(FHeaderHandle, 'ItemsView', nil);
- if DarkMode then UpdateDarkMode;
- end;
- NeedImageLists(False);
- end;
- procedure TCustomDirView.LVMSetExtendedListViewStyle(var Message: TMessage);
- // Only TWinControl.DoubleBuffered actually prevents flicker
- // on Win7 when moving mouse over list view, not LVS_EX_DOUBLEBUFFER.
- // But LVS_EX_DOUBLEBUFFER brings nice alpha blended marquee selection.
- // Double buffering introduces artefacts when scrolling using
- // keyboard (Page-up/Down). This gets fixed by LVS_EX_TRANSPARENTBKGND,
- // but that works on Vista and newer only. See WMKeyDown
- // for workaround on earlier systems.
- begin
- // This prevents TCustomListView.ResetExStyles resetting our styles
- if Enabled and
- (Message.WParam = 0) and
- ((Message.LParam and RequiredStyles) <> RequiredStyles) then
- begin
- ListView_SetExtendedListViewStyle(Handle, Message.LParam or RequiredStyles);
- end
- else
- begin
- inherited;
- end;
- end;
- procedure TCustomDirView.DestroyWnd;
- begin
- // to force drag&drop re-registration when recreating handle
- // (occurs when changing ViewStyle)
- FDragDropFilesEx.DragDropControl := nil;
- inherited;
- end;
- procedure TCustomDirView.CMRecreateWnd(var Message: TMessage);
- var
- HadHandle: Boolean;
- begin
- Inc(FRecreatingWnd);
- if FRecreatingWnd = 1 then
- begin
- HadHandle := HandleAllocated;
- try
- // Prevent nesting
- while FRecreatingWnd > 0 do
- begin
- inherited;
- Dec(FRecreatingWnd);
- end;
- finally
- FRecreatingWnd := 0;
- end;
- // See comment in TCustomDriveView.CMRecreateWnd
- if HadHandle then
- begin
- HandleNeeded;
- end;
- end;
- end;
- function TCustomDirView.DoItemColor(Item: TListItem): TColor;
- var
- Precision: TDateTimePrecision;
- begin
- Result := clDefaultItemColor;
- if Assigned(OnGetItemColor) then
- begin
- OnGetItemColor(Self, ItemFullFileName(Item), ItemIsDirectory(Item), ItemFileSize(Item), ItemFileTime(Item, Precision), Result);
- end;
- end;
- procedure TCustomDirView.DoCustomDrawItem(Item: TListItem; Stage: TCustomDrawStage);
- var
- Color: TColor;
- begin
- if (Item <> nil) and (Stage = cdPrePaint) then
- begin
- Color := DoItemColor(Item);
- if Color = clDefaultItemColor then Color := ItemColor(Item);
- if (Color <> clDefaultItemColor) and
- (Canvas.Font.Color <> Color) then
- begin
- Canvas.Font.Color := Color;
- end;
- end;
- end;
- function TCustomDirView.CustomDrawItem(Item: TListItem; State: TCustomDrawState;
- Stage: TCustomDrawStage): Boolean;
- begin
- DoCustomDrawItem(Item, Stage);
- Result := inherited CustomDrawItem(Item, State, Stage);
- end;
- function TCustomDirView.CustomDrawSubItem(Item: TListItem; SubItem: Integer;
- State: TCustomDrawState; Stage: TCustomDrawStage): Boolean;
- begin
- DoCustomDrawItem(Item, Stage);
- Result := inherited CustomDrawSubItem(Item, SubItem, State, Stage);
- end;
- procedure TCustomDirView.Delete(Item: TListItem);
- begin
- if Assigned(Item) then
- begin
- // This causes access violation when size is stored in structure
- // pointed by TListItem->Data and this structure is not valid any more
- if Valid then Dec(FFilesSize, ItemFileSize(Item));
- inherited Delete(Item);
- end;
- end;
- destructor TCustomDirView.Destroy;
- begin
- Assert(not FSavedSelection);
- FreeAndNil(FScrollOnDragOver);
- FreeAndNil(FSavedNames);
- FreeAndNil(FHistoryPaths);
- FreeAndNil(FDragDropFilesEx);
- FreeImageLists;
- FreeThumbnails;
- inherited;
- end;
- procedure TCustomDirView.SelectFiles(Filter: TFileFilter; Select: Boolean);
- var
- Item: TListItem;
- Index: Integer;
- OldCursor: TCursor;
- begin
- Assert(Valid);
- OldCursor := Screen.Cursor;
- Items.BeginUpdate;
- BeginSelectionUpdate;
- try
- Screen.Cursor := crHourGlass;
- for Index := 0 to Items.Count-1 do
- begin
- Item := Items[Index];
- Assert(Assigned(Item));
- if (GetItemSelectedByIndex(Index) <> Select) and
- ItemMatchesFilter(Item, Filter) then
- SetItemSelectedByIndex(Index, Select);
- end;
- finally
- Screen.Cursor := OldCursor;
- Items.EndUpdate;
- EndSelectionUpdate;
- end;
- end;
- function TCustomDirView.DragCompleteFileList: Boolean;
- begin
- Result := (MarkedCount <= 100) and (not IsRecycleBin);
- end;
- procedure TCustomDirView.DumbCustomDrawItem(Sender: TCustomListView; Item: TListItem; State: TCustomDrawState; var DefaultDraw: Boolean);
- begin
- end;
- procedure TCustomDirView.DumbCustomDrawSubItem(Sender: TCustomListView;
- Item: TListItem; SubItem: Integer; State: TCustomDrawState;
- var DefaultDraw: Boolean);
- begin
- end;
- function TCustomDirView.GetTargetPopupMenu: Boolean;
- begin
- if Assigned(FDragDropFilesEx) then Result := FDragDropFilesEx.TargetPopupMenu
- else Result := True;
- end;
- procedure TCustomDirView.SetMultiSelect(Value: Boolean);
- begin
- if Value <> MultiSelect then
- begin
- inherited SetMultiSelect(Value);
- if not (csLoading in ComponentState) and Assigned(ColProperties) then
- begin
- ColProperties.RecreateColumns;
- SetColumnImages;
- if DirOK then Reload(True);
- end;
- end;
- end;
- function TCustomDirView.GetValid: Boolean;
- begin
- Result := (not (csDestroying in ComponentState)) and
- (not Loading) and (not FClearingItems);
- end;
- function TCustomDirView.ItemCanDrag(Item: TListItem): Boolean;
- begin
- Result := (not ItemIsParentDirectory(Item));
- end;
- function TCustomDirView.ItemColor(Item: TListItem): TColor;
- begin
- Result := clDefaultItemColor;
- end;
- function TCustomDirView.ItemThumbnail(Item: TListItem; Size: TSize): TBitmap;
- begin
- Result := nil;
- end;
- procedure TCustomDirView.FreeThumbnails;
- begin
- FreeAndNil(FFallbackThumbnail[True]);
- FreeAndNil(FFallbackThumbnail[False]);
- end;
- function TCustomDirView.FallbackThumbnail(Dir: Boolean; Size: TSize): TBitmap;
- var
- FallbackPath: string;
- Existed: Boolean;
- Index: Integer;
- begin
- Result := nil;
- try
- if FFallbackThumbnailSize <> Size then
- begin
- FreeThumbnails;
- end;
- if not Assigned(FFallbackThumbnail[Dir]) then
- begin
- Index := 1;
- repeat
- FallbackPath := TPath.Combine(TempDir, 'default.' + IntToStr(Index) + '.thumbnailimage');
- Existed := FileExists(FallbackPath) or DirectoryExists(FallbackPath);
- if not Existed then
- begin
- if Dir then
- CreateDir(FallbackPath)
- else
- TFile.WriteAllText(FallbackPath, '');
- end;
- Inc(Index);
- until not Existed;
- FFallbackThumbnailSize := Size;
- FFallbackThumbnail[Dir] := GetThumbnail(FallbackPath, Size);
- if Existed then
- begin
- if Dir then
- RemoveDir(FallbackPath)
- else
- DeleteFile(FallbackPath);
- end;
- end;
- Result := FFallbackThumbnail[Dir];
- except
- end;
- end;
- function TCustomDirView.GetFilesMarkedSize: Int64;
- begin
- if SelCount > 0 then Result := FilesSelSize
- else
- if Assigned(ItemFocused) then Result := ItemFileSize(ItemFocused)
- else Result := 0;
- end;
- function TCustomDirView.ItemIsRecycleBin(Item: TListItem): Boolean;
- begin
- Result := False;
- end;
- function TCustomDirView.ItemOverlayIndexes(Item: TListItem): Word;
- begin
- Result := oiNoOverlay;
- if Assigned(OnGetOverlay) then
- OnGetOverlay(Self, Item, Result);
- end;
- function TCustomDirView.IsItemVisible(Item: TListItem): Boolean;
- begin
- Result := (ListView_IsItemVisible(Handle, Item.Index) <> 0);
- end;
- procedure TCustomDirView.WMKeyDown(var Message: TWMKeyDown);
- begin
- if DoubleBuffered and (Message.CharCode in [VK_PRIOR, VK_NEXT]) and
- FDoubleBufferedScrollingWorkaround then
- begin
- // WORKAROUND
- // When scrolling with double-buffering enabled, ugly artefacts
- // are shown temporarily.
- // LVS_EX_TRANSPARENTBKGND fixes it on Vista and newer
- SendMessage(Handle, WM_SETREDRAW, 0, 0);
- try
- inherited;
- finally
- SendMessage(Handle, WM_SETREDRAW, 1, 0);
- end;
- Repaint;
- end
- else
- begin
- inherited;
- end;
- end;
- procedure TCustomDirView.DoDisplayPropertiesMenu;
- begin
- if not IsBusy then
- DisplayPropertiesMenu;
- end;
- procedure TCustomDirView.DoExecute(Item: TListItem; ForceEnter: Boolean);
- begin
- BusyOperation(procedure begin Execute(Item, ForceEnter); end);
- end;
- procedure TCustomDirView.DoExecuteParentDirectory;
- begin
- BusyOperation(ExecuteParentDirectory);
- end;
- procedure TCustomDirView.CNKeyDown(var Message: TWMKeyDown);
- begin
- // Prevent Backspace being handled via "Parent directory" command in the context menu.
- // We want it handled here in KeyDown
- // (among other as the mechanism there makes sure it works differently while incrementally searching).
- if Message.CharCode <> VK_BACK then
- begin
- inherited;
- end;
- end;
- procedure TCustomDirView.KeyDown(var Key: Word; Shift: TShiftState);
- var
- AKey: Word;
- begin
- if Valid and (not IsEditing) and (not Loading) then
- begin
- if (Key = VK_RETURN) or
- ((Key = VK_NEXT) and (ssCtrl in Shift)) then
- begin
- if Assigned(ItemFocused) then
- begin
- AKey := Key;
- Key := 0;
- if (AKey = VK_RETURN) and (Shift = [ssAlt]) then DoDisplayPropertiesMenu
- else
- if (AKey <> VK_RETURN) or (Shift = []) then DoExecute(ItemFocused, (AKey <> VK_RETURN));
- end;
- end
- else
- if ((Key = VK_BACK) or ((Key = VK_PRIOR) and (ssCtrl in Shift))) and
- (not IsRoot) then
- begin
- inherited;
- // If not handled in TCustomScpExplorerForm::DirViewKeyDown
- if Key <> 0 then
- begin
- Key := 0;
- DoExecuteParentDirectory;
- end;
- end
- else
- if ((Key = VK_UP) and (ssAlt in Shift)) and
- (not IsRoot) then
- begin
- Key := 0;
- // U+25D8 is 'INVERSE BULLET', what is glyph representing '\x8' (or '\b')
- // ('up' key is the '8' key on numeric pad)
- // We could obtain the value programatically using
- // MultiByteToWideChar(CP_OEMCP, MB_USEGLYPHCHARS, "\x8", 1, ...)
- FNextCharToIgnore := $25D8;
- DoExecuteParentDirectory;
- end
- else
- if (Key = 220 { backslash }) and (ssCtrl in Shift) and (not IsRoot) then
- begin
- Key := 0;
- BusyOperation(ExecuteRootDirectory);
- end
- else
- if (Key = VK_LEFT) and (ssAlt in Shift) then
- begin
- if BackCount >= 1 then DoHistoryGo(-1);
- end
- else
- if (Key = VK_RIGHT) and (ssAlt in Shift) then
- begin
- if ForwardCount >= 1 then DoHistoryGo(1);
- end
- else
- begin
- inherited;
- end;
- end
- else
- begin
- inherited;
- end;
- end;
- procedure TCustomDirView.KeyPress(var Key: Char);
- begin
- if IsEditing and (Pos(Key, FInvalidNameChars) <> 0) Then
- begin
- Beep;
- Key := #0;
- end;
- inherited;
- end;
- procedure TCustomDirView.DisplayContextMenuInSitu;
- var
- R: TRect;
- P: TPoint;
- begin
- if Assigned(ItemFocused) then
- begin
- R := ItemFocused.DisplayRect(drIcon);
- P.X := (R.Left + R.Right) div 2;
- P.Y := (R.Top + R.Bottom) div 2;
- end
- else
- begin
- P.X := 0;
- P.Y := 0;
- end;
- P := ClientToScreen(P);
- DisplayContextMenu(P);
- end;
- procedure TCustomDirView.KeyUp(var Key: Word; Shift: TShiftState);
- var
- P: TPoint;
- begin
- if Key = VK_APPS then
- begin
- if (not Loading) and (not IsBusy) then
- begin
- if MarkedCount > 0 then
- begin
- DisplayContextMenuInSitu;
- end
- else
- if Assigned(PopupMenu) then
- begin
- P.X := 0;
- P.Y := 0;
- P := ClientToScreen(P);
- PopupMenu.Popup(P.X, P.Y);
- end;
- end;
- end
- else
- inherited KeyUp(Key, Shift);
- end;
- procedure TCustomDirView.SetWatchForChanges(Value: Boolean);
- begin
- if FWatchForChanges <> Value then
- FWatchForChanges := Value;
- end;
- function TCustomDirView.TargetHasDropHandler(Item: TListItem; Effect: Integer): Boolean;
- begin
- Assert(Assigned(DragDropFilesEx) and Assigned(Item));
- Result :=
- DragDropFilesEx.TargetHasDropHandler(nil, ItemFullFileName(Item), Effect);
- if Assigned(OnDDTargetHasDropHandler) then
- begin
- OnDDTargetHasDropHandler(Self, Item, Effect, Result);
- end;
- end;
- procedure TCustomDirView.UpdatePathLabelCaption;
- begin
- PathLabel.Caption := PathName;
- // Do not display mask on otherwise empty label (i.e. on a disconnected remote panel)
- if PathLabel.Caption <> '' then PathLabel.Mask := Mask
- else PathLabel.Mask := '';
- end;
- procedure TCustomDirView.UpdatePathLabel;
- begin
- if Assigned(PathLabel) then
- begin
- if csDesigning in ComponentState then
- begin
- PathLabel.Caption := PathLabel.Name;
- PathLabel.Mask := '';
- end
- else
- begin
- UpdatePathLabelCaption;
- end;
- PathLabel.UpdateStatus;
- end;
- end; { UpdatePathLabel }
- procedure TCustomDirView.DoUpdateStatusBar(Force: Boolean);
- var
- StatusFileInfo: TStatusFileInfo;
- begin
- if (FUpdatingSelection = 0) and Assigned(OnUpdateStatusBar) then
- begin
- with StatusFileInfo do
- begin
- SelectedSize := FilesSelSize;
- FilesSize := Self.FilesSize;
- SelectedCount := SelCount;
- FilesCount := Self.FilesCount;
- HiddenCount := Self.HiddenCount;
- FilteredCount := Self.FilteredCount;
- end;
- if Force or (not CompareMem(@StatusFileInfo, @FStatusFileInfo, SizeOf(StatusFileInfo))) then
- begin
- FStatusFileInfo := StatusFileInfo;
- OnUpdateStatusBar(Self, FStatusFileInfo);
- end;
- end;
- end; { UpdateStatusBar }
- procedure TCustomDirView.UpdateStatusBar;
- begin
- DoUpdateStatusBar(True);
- end;
- procedure TCustomDirView.WMContextMenu(var Message: TWMContextMenu);
- var
- Point: TPoint;
- begin
- FDragEnabled := False;
- if Assigned(PopupMenu) then
- PopupMenu.AutoPopup := False;
- //inherited;
- if FContextMenu and (not Loading) then
- begin
- Point.X := Message.XPos;
- Point.Y := Message.YPos;
- Point := ScreenToClient(Point);
- if Assigned(OnMouseDown) then
- begin
- OnMouseDown(Self, mbRight, [], Point.X, Point.Y);
- end;
- if FUseSystemContextMenu and Assigned(ItemFocused) and
- (GetItemAt(Point.X, Point.Y) = ItemFocused) then
- begin
- Point.X := Message.XPos;
- Point.Y := Message.YPos;
- DisplayContextMenu(Point);
- end
- else
- if Assigned(PopupMenu) and (not PopupMenu.AutoPopup) then
- begin
- PopupMenu.Popup(Message.XPos, Message.YPos);
- end;
- end;
- FContextMenu := False;
- //inherited;
- end;
- function TCustomDirView.EnableDragOnClick: Boolean;
- begin
- Result := (not Loading) and inherited EnableDragOnClick;
- end;
- procedure TCustomDirView.WMLButtonDown(var Message: TWMLButtonDown);
- begin
- GetCursorPos(FStartPos);
- FDragEnabled := EnableDragOnClick;
- inherited;
- end;
- procedure TCustomDirView.WMRButtonDown(var Message: TWMRButtonDown);
- begin
- GetCursorPos(FStartPos);
- if FDragDropFilesEx.DragDetectStatus <> ddsDrag then
- FDragEnabled := EnableDragOnClick;
- FContextMenu := True;
- inherited;
- end;
- procedure TCustomDirView.WMLButtonDblClk(var Message: TWMLButtonDblClk);
- begin
- inherited;
- if Assigned(ItemFocused) and (not Loading) and
- (GetItemAt(Message.XPos, Message.YPos) = ItemFocused) then
- begin
- if GetKeyState(VK_MENU) < 0 then DoDisplayPropertiesMenu
- else DoExecute(ItemFocused, False);
- end;
- end;
- procedure TCustomDirView.WMLButtonUp(var Message: TWMLButtonUp);
- begin
- FDragEnabled := False;
- inherited;
- end;
- procedure TCustomDirView.WMXButtonUp(var Message: TWMXMouse);
- begin
- if Message.Button = _XBUTTON1 then
- begin
- if BackCount >= 1 then DoHistoryGo(-1);
- Message.Result := 1;
- end
- else
- if Message.Button = _XBUTTON2 then
- begin
- if ForwardCount >= 1 then DoHistoryGo(1);
- Message.Result := 1;
- end;
- end;
- procedure TCustomDirView.CancelEdit;
- begin
- // - Do nothing when handle is not allocated (we cannot be editing anyway
- // without a handle), otherwise this causes handle allocation,
- // what is wrong particularly when we are called from ClearItems
- // when we are being destroyed
- // - If editing, it has to be focused item
- if HandleAllocated and IsEditing and Assigned(ItemFocused) then
- begin
- ItemFocused.CancelEdit;
- FLoadEnabled := True;
- end;
- end;
- procedure TCustomDirView.Reload(CacheIcons: Boolean);
- var
- OldSelection: TStringList;
- OldItemFocused: string;
- OldFocusedShown: Boolean;
- OldShownItemOffset: Integer;
- Index: Integer;
- FoundIndex: Integer;
- IconCache: TStringList;
- Item: TListItem;
- ItemToFocus: TListItem;
- FileName: string;
- begin
- if Path <> '' then
- begin
- CancelEdit;
- OldSelection := nil;
- IconCache := nil;
- Items.BeginUpdate;
- try
- OldSelection := TStringList.Create;
- OldSelection.CaseSensitive := FCaseSensitive;
- if CacheIcons then
- IconCache := TStringList.Create;
- for Index := 0 to Items.Count-1 do
- begin
- Item := Items[Index];
- // cannot use ItemFileName as for TUnixDirView the file object
- // is no longer valid
- FileName := Item.Caption;
- if GetItemSelectedByIndex(Index) then
- OldSelection.Add(FileName);
- if CacheIcons and (ItemImageIndex(Item, True) >= 0) then
- IconCache.AddObject(FileName, TObject(ItemImageIndex(Item, True)));
- end;
- if FSelectFile <> '' then
- begin
- OldItemFocused := FSelectFile;
- OldFocusedShown := False;
- OldShownItemOffset := -1;
- FSelectFile := '';
- end
- else
- begin
- SaveItemsState(OldItemFocused, OldFocusedShown, OldShownItemOffset);
- end;
- Load(False);
- OldSelection.Sort;
- if CacheIcons then IconCache.Sort;
- ItemToFocus := nil;
- for Index := 0 to Items.Count - 1 do
- begin
- Item := Items[Index];
- FileName := ItemFileName(Item);
- if FileName = OldItemFocused then
- ItemToFocus := Item;
- if OldSelection.Find(FileName, FoundIndex) then
- SetItemSelectedByIndex(Index, True);
- if CacheIcons and (ItemImageIndex(Item, True) < 0) then
- begin
- FoundIndex := IconCache.IndexOf(FileName);
- if FoundIndex >= 0 then
- SetItemImageIndex(Item, Integer(IconCache.Objects[FoundIndex]));
- end;
- end;
- finally
- Items.EndUpdate;
- OldSelection.Free;
- if CacheIcons then IconCache.Free;
- end;
- // This is below Items.EndUpdate(), to make Scroll() work properly
- RestoreItemsState(ItemToFocus, OldFocusedShown, OldShownItemOffset);
- FocusSomething(False);
- end;
- end;
- procedure TCustomDirView.Load(DoFocusSomething: Boolean);
- var
- SaveCursor: TCursor;
- Delimiters: string;
- LastDirName: string;
- begin
- if not FLoadEnabled or Loading then
- begin
- FDirty := True;
- FAbortLoading := True;
- end
- else
- begin
- FLoading := True;
- FInsertingNewUnselectedItem := True;
- try
- FHasParentDir := False;
- if Assigned(FOnStartLoading) then FOnStartLoading(Self);
- SaveCursor := Screen.Cursor;
- Screen.Cursor := crHourGlass;
- try
- FNotifyEnabled := False;
- ClearItems;
- FFilesSize := 0;
- FFilesSelSize := 0;
- SortType := stNone;
- Items.BeginUpdate;
- try
- LoadFiles;
- finally
- Items.EndUpdate;
- end;
- finally
- Screen.Cursor := SaveCursor;
- end;
- finally
- FLoading := False;
- FInsertingNewUnselectedItem := False;
- try
- if FAbortLoading then
- begin
- FAbortLoading := False;
- Reload(False);
- end
- else
- begin
- if DirOK then SortItems;
- FAbortLoading := False;
- FDirty := False;
- if (Length(LastPath) > Length(PathName)) and
- (Copy(LastPath, 1, Length(PathName)) = PathName) and
- (Items.Count > 0) then
- begin
- LastDirName := Copy(LastPath, Length(PathName) + 1, MaxInt);
- Delimiters := '\:/';
- if IsDelimiter(Delimiters, LastDirName, 1) then
- begin
- LastDirName := Copy(LastDirName, 2, MaxInt);
- end;
- if LastDelimiter(Delimiters, LastDirName) = 0 then
- begin
- ItemFocused := FindFileItem(LastDirName);
- end;
- end;
- end;
- finally
- // nested try .. finally block is included
- // because we really want these to be executed
- FNotifyEnabled := True;
- if DoFocusSomething then
- begin
- if FAnnouncedState is TDirViewState then
- begin
- RestoreItemsState(FAnnouncedState);
- end;
- FocusSomething(False);
- end;
- if Assigned(FOnLoaded) then
- begin
- FOnLoaded(Self);
- end;
- UpdatePathLabel;
- DoUpdateStatusBar;
- end;
- end;
- end;
- end;
- procedure TCustomDirView.SetLoadEnabled(Enabled: Boolean);
- begin
- if Enabled <> LoadEnabled then
- begin
- FLoadEnabled := Enabled;
- if Enabled and Dirty then Reload(True);
- end;
- end;
- function TCustomDirView.GetFilesCount: Integer;
- begin
- Result := Items.Count;
- if (Result > 0) and HasParentDir then Dec(Result);
- end;
- procedure TCustomDirView.ViewStyleChanged;
- begin
- // this is workaround for bug in TCustomNortonLikeListView
- // that clears Items on recreating wnd (caused by change to ViewStyle)
- Reload(True);
- end;
- procedure TCustomDirView.SetViewStyle(Value: TViewStyle);
- begin
- if (Value <> ViewStyle) and (not FLoading) then
- begin
- FNotifyEnabled := False;
- inherited;
- FNotifyEnabled := True;
- ViewStyleChanged;
- end;
- end;
- procedure TCustomDirView.ColClick(Column: TListColumn);
- var
- ScrollToFocused: Boolean;
- begin
- ScrollToFocused := Assigned(ItemFocused);
- inherited;
- if ScrollToFocused and Assigned(ItemFocused) then
- ItemFocused.MakeVisible(False);
- end;
- procedure TCustomDirView.CustomSortItems(SortProc: Pointer);
- var
- SavedCursor: TCursor;
- SavedNotifyEnabled: Boolean;
- begin
- if HandleAllocated then
- begin
- SavedNotifyEnabled := FNotifyEnabled;
- SavedCursor := Screen.Cursor;
- Items.BeginUpdate;
- try
- Screen.Cursor := crHourglass;
- FNotifyEnabled := False;
- CustomSort(TLVCompare(SortProc), Integer(Pointer(Self)));
- finally
- Screen.Cursor := SavedCursor;
- FNotifyEnabled := SavedNotifyEnabled;
- Items.EndUpdate;
- ItemsReordered;
- end;
- end;
- end;
- procedure TCustomDirView.ReloadForce(CacheIcons: Boolean);
- begin
- FLoadEnabled := True;
- FDirty := False;
- Reload(CacheIcons);
- end;
- procedure TCustomDirView.ScrollOnDragOverBeforeUpdate(ObjectToValidate: TObject);
- begin
- GlobalDragImageList.HideDragImage;
- end;
- procedure TCustomDirView.ScrollOnDragOverAfterUpdate;
- begin
- GlobalDragImageList.ShowDragImage;
- end;
- procedure TCustomDirView.DDDragEnter(DataObj: IDataObject; grfKeyState: Longint;
- Point: TPoint; var dwEffect: longint; var Accept: Boolean);
- var
- Index: Integer;
- begin
- Accept := Accept and DirOK and (not Loading);
- if Accept and
- (DragDropFilesEx.FileList.Count > 0) and
- (Length(TFDDListItem(DragDropFilesEx.FileList[0]^).Name) > 0) and
- (not IsRecycleBin or not DragDropFilesEx.FileNamesAreMapped) then
- begin
- try
- FDragDrive := DriveInfo.GetDriveKey(TFDDListItem(DragDropFilesEx.FileList[0]^).Name);
- except
- // WinRAR gives us only filename on "enter", we get a full path only on "drop".
- FDragDrive := '';
- end;
- FExeDrag := FDDLinkOnExeDrag and
- (deLink in DragDropFilesEx.TargetEffects) and
- ((DragDropFilesEx.AvailableDropEffects and DROPEFFECT_LINK) <> 0);
- if FExeDrag then
- begin
- for Index := 0 to DragDropFilesEx.FileList.Count - 1 do
- if not IsExecutable(TFDDListItem(DragDropFilesEx.FileList[Index]^).Name) then
- begin
- FExeDrag := False;
- Break;
- end;
- end;
- end
- else
- begin
- FDragDrive := '';
- end;
- FScrollOnDragOver.StartDrag;
- if Assigned(FOnDDDragEnter) then
- FOnDDDragEnter(Self, DataObj, grfKeyState, Point, dwEffect, Accept);
- end;
- procedure TCustomDirView.DDDragLeave;
- begin
- if Assigned(DropTarget) then
- begin
- if GlobalDragImageList.Dragging then
- GlobalDragImageList.HideDragImage;
- DropTarget := nil;
- Update; {ie30}
- end
- else DropTarget := nil;
- if Assigned(FOnDDDragLeave) then
- FOnDDDragLeave(Self);
- end;
- procedure TCustomDirView.DDDragOver(grfKeyState: Integer; Point: TPoint;
- var dwEffect: Integer; PreferredEffect: Integer);
- var
- DropItem: TListItem;
- CanDrop: Boolean;
- HasDropHandler: Boolean;
- begin
- FDDOwnerIsSource := DragDropFilesEx.OwnerIsSource;
- {Set droptarget if target is directory:}
- if not Loading then DropItem := GetItemAt(Point.X, Point.Y)
- else DropItem := nil;
- HasDropHandler := (Assigned(DropItem) and (not IsRecycleBin) and
- TargetHasDropHandler(DropItem, dwEffect));
- CanDrop := Assigned(DropItem) and (not IsRecycleBin) and
- (ItemIsDirectory(DropItem) or HasDropHandler);
- if (CanDrop and (DropTarget <> DropItem)) or
- (not CanDrop and Assigned(DropTarget)) then
- begin
- if GlobalDragImageList.Dragging then
- begin
- GlobalDragImageList.HideDragImage;
- DropTarget := nil;
- Update;
- if CanDrop then
- begin
- DropTarget := DropItem;
- Update;
- end;
- GlobalDragImageList.ShowDragImage;
- end
- else
- begin
- DropTarget := nil;
- if CanDrop then DropTarget := DropItem;
- end;
- end;
- if not Loading then
- FScrollOnDragOver.DragOver(Point);
- {Set dropeffect:}
- if (not HasDropHandler) and (not Loading) then
- begin
- DDChooseEffect(grfKeyState, dwEffect, PreferredEffect);
- if Assigned(FOnDDDragOver) then
- FOnDDDragOver(Self, grfKeyState, Point, dwEffect);
- // cannot drop to dragged files
- if DragDropFilesEx.OwnerIsSource and Assigned(DropItem) then
- begin
- if Assigned(ItemFocused) and (not ItemFocused.Selected) then
- begin
- if DropItem = ItemFocused then
- begin
- dwEffect := DROPEFFECT_NONE;
- end;
- end
- else
- if DropItem.Selected then
- begin
- dwEffect := DROPEFFECT_NONE;
- end;
- end;
- if DragDropFilesEx.OwnerIsSource and (dwEffect = DROPEFFECT_MOVE) and
- (not Assigned(DropTarget)) then
- begin
- dwEffect := DROPEFFECT_NONE;
- end
- else
- if Assigned(DropTarget) and ItemIsRecycleBin(DropTarget) and
- (dwEffect <> DROPEFFECT_NONE) then
- begin
- dwEffect := DROPEFFECT_MOVE;
- end;
- end;
- end;
- function TCustomDirView.ItemData(Item: TListItem): TObject;
- begin
- Result := nil;
- end;
- function TCustomDirView.OperateOnFocusedFile(Focused, OnlyFocused: Boolean): Boolean;
- begin
- Result :=
- Assigned(ItemFocused) and
- ((Focused and (not ItemFocused.Selected)) or (SelCount = 0) or OnlyFocused);
- end;
- function TCustomDirView.CustomCreateFileList(Focused, OnlyFocused: Boolean;
- FullPath: Boolean; FileList: TStrings; ItemObject: Boolean): TStrings;
- procedure AddItem(Item: TListItem);
- var
- AObject: TObject;
- begin
- Assert(Assigned(Item));
- if ItemObject then AObject := Item
- else AObject := ItemData(Item);
- if FullPath then Result.AddObject(ItemFullFileName(Item), AObject)
- else Result.AddObject(ItemFileName(Item), AObject);
- end;
- var
- Item: TListItem;
- begin
- if Assigned(FileList) then Result := FileList
- else Result := TStringList.Create;
- try
- if OperateOnFocusedFile(Focused, OnlyFocused) then
- begin
- AddItem(ItemFocused)
- end
- else
- begin
- Item := GetNextItem(nil, sdAll, [isSelected]);
- while Assigned(Item) do
- begin
- AddItem(Item);
- Item := GetNextItem(Item, sdAll, [isSelected]);
- end;
- end;
- except
- if not Assigned(FileList) then FreeAndNil(Result);
- raise;
- end;
- end;
- function TCustomDirView.CreateFocusedFileList(FullPath: Boolean; FileList: TStrings): TStrings;
- begin
- Result := CustomCreateFileList(False, True, FullPath, FileList);
- end;
- function TCustomDirView.CreateFileList(Focused: Boolean; FullPath: Boolean;
- FileList: TStrings; ItemObject: Boolean): TStrings;
- begin
- Result := CustomCreateFileList(Focused, False, FullPath, FileList, ItemObject);
- end;
- procedure TCustomDirView.DDDrop(DataObj: IDataObject; grfKeyState: Integer;
- Point: TPoint; var dwEffect: Integer);
- begin
- if GlobalDragImageList.Dragging then
- GlobalDragImageList.HideDragImage;
- if dwEffect = DROPEFFECT_NONE then
- DropTarget := nil;
- if Assigned(OnDDDrop) then
- OnDDDrop(Self, DataObj, grfKeyState, Point, dwEffect);
- end;
- procedure TCustomDirView.DDQueryContinueDrag(FEscapePressed: LongBool;
- grfKeyState: Integer; var Result: HResult);
- var
- MousePos: TPoint;
- KnowTime: TFileTime;
- begin
- // this method cannot throw exceptions, if it does d&d will not be possible
- // anymore (see TDragDrop.ExecuteOperation, global GInternalSource)
- if Result = DRAGDROP_S_DROP then
- begin
- GetSystemTimeAsFileTime(KnowTime);
- if ((Int64(KnowTime) - Int64(FDragStartTime)) <= DDDragStartDelay) then
- Result := DRAGDROP_S_CANCEL;
- end;
- if Assigned(OnDDQueryContinueDrag) then
- begin
- OnDDQueryContinueDrag(Self, FEscapePressed, grfKeyState, Result);
- end;
- try
- if FEscapePressed then
- begin
- if GlobalDragImageList.Dragging then
- GlobalDragImageList.HideDragImage;
- end
- else
- begin
- if GlobalDragImageList.Dragging Then
- begin
- MousePos := ParentForm.ScreenToClient(Mouse.CursorPos);
- {Move the drag image to the new position and show it:}
- if (MousePos.X <> FDragPos.X) or (MousePos.Y <> FDragPos.Y) then
- begin
- FDragPos := MousePos;
- if PtInRect(ParentForm.BoundsRect, Mouse.CursorPos) then
- begin
- GlobalDragImageList.DragMove(MousePos.X, MousePos.Y);
- GlobalDragImageList.ShowDragImage;
- end
- else GlobalDragImageList.HideDragImage;
- end;
- end;
- end;
- except
- // do not care if the above fails
- // (Mouse.CursorPos fails when desktop is locked by user)
- end;
- end;
- procedure TCustomDirView.DDSpecifyDropTarget(Sender: TObject;
- DragDropHandler: Boolean; Point: TPoint; var pidlFQ: PItemIDList;
- var Filename: string);
- var
- Item: TListItem;
- begin
- pidlFQ := nil;
- if DirOK and (not Loading) then
- begin
- if DragDropHandler then
- begin
- if Assigned(DropTarget) and ItemIsDirectory(DropTarget) then
- FileName := ItemFullFileName(DropTarget)
- else
- FileName := PathName;
- end
- else
- begin
- Item := GetItemAt(Point.X, Point.Y);
- if Assigned(Item) and (not ItemIsDirectory(Item)) and
- (not IsRecycleBin) then
- FileName := ItemFullFileName(Item)
- else
- FileName := '';
- end;
- end
- else FileName := '';
- end;
- procedure TCustomDirView.DDMenuPopup(Sender: TObject; AMenu: HMenu;
- DataObj: IDataObject; AMinCustCmd: Integer; grfKeyState: Longint; pt: TPoint);
- begin
- end;
- procedure TCustomDirView.DDMenuDone(Sender: TObject; AMenu: HMenu);
- begin
- end;
- procedure TCustomDirView.DDDropHandlerSucceeded(Sender: TObject;
- grfKeyState: Integer; Point: TPoint; dwEffect: Integer);
- begin
- DropTarget := nil;
- end;
- procedure TCustomDirView.DDChooseEffect(grfKeyState: Integer; var dwEffect: Integer; PreferredEffect: Integer);
- begin
- if Assigned(FOnDDChooseEffect) then
- FOnDDChooseEffect(Self, grfKeyState, dwEffect);
- end;
- procedure TCustomDirView.DDGiveFeedback(dwEffect: Integer;
- var Result: HResult);
- begin
- if Assigned(FOnDDGiveFeedback) then
- FOnDDGiveFeedback(Self, dwEffect, Result);
- end;
- procedure TCustomDirView.DDProcessDropped(Sender: TObject;
- grfKeyState: Integer; Point: TPoint; dwEffect: Integer);
- begin
- if DirOK and (not Loading) then
- try
- try
- if Assigned(FOnDDProcessDropped) then
- FOnDDProcessDropped(Self, grfKeyState, Point, dwEffect);
- if dwEffect <> DROPEFFECT_NONE then
- begin
- PerformItemDragDropOperation(DropTarget, dwEffect, False);
- if Assigned(FOnDDExecuted) then
- FOnDDExecuted(Self, dwEffect);
- end;
- finally
- DragDropFilesEx.FileList.Clear;
- DropTarget := nil;
- end;
- except
- Application.HandleException(Self);
- end;
- end;
- function TCustomDirView.AnyFileSelected(
- OnlyFocused: Boolean; FilesOnly: Boolean; FocusedFileOnlyWhenFocused: Boolean): Boolean;
- var
- Item: TListItem;
- begin
- if OnlyFocused or
- ((SelCount = 0) and
- ((not FocusedFileOnlyWhenFocused) or
- (Focused and (GetParentForm(Self).Handle = GetForegroundWindow())))) then
- begin
- Result := Assigned(ItemFocused) and ItemIsFile(ItemFocused) and
- ((not FilesOnly) or (not ItemIsDirectory(ItemFocused)));
- end
- else
- begin
- Result := True;
- Item := GetNextItem(nil, sdAll, [isSelected]);
- while Assigned(Item) do
- begin
- if ItemIsFile(Item) and
- ((not FilesOnly) or (not ItemIsDirectory(Item))) then Exit;
- Item := GetNextItem(Item, sdAll, [isSelected]);
- end;
- Result := False;
- end;
- end;
- function TCustomDirView.CanEdit(Item: TListItem): Boolean;
- begin
- Result :=
- (inherited CanEdit(Item) or FForceRename) and (not Loading) and
- Assigned(Item) and (not ReadOnly) and (not IsRecycleBin) and
- (not ItemIsParentDirectory(Item));
- if Result then FLoadEnabled := False;
- FForceRename := False;
- end;
- function TCustomDirView.CanChangeSelection(Item: TListItem;
- Select: Boolean): Boolean;
- begin
- Result :=
- (not Loading) and
- not (Assigned(Item) and Assigned(Item.Data) and
- ItemIsParentDirectory(Item));
- end;
- procedure TCustomDirView.Edit(const HItem: TLVItem);
- var
- Info: string;
- Index: Integer;
- begin
- // When rename is confirmed by clicking outside of the edit box, and the actual rename operation
- // displays error message or simply pumps a message queue (like during lenghty remote directory reload),
- // drag mouse selection start. It posssibly happens only on the remote panel due to it being completely reloaded.
- ReleaseCapture;
- if Length(HItem.pszText) = 0 then LoadEnabled := True
- else
- begin
- {Does the changed filename contains invalid characters?}
- if StrContains(FInvalidNameChars, HItem.pszText) then
- begin
- Info := FInvalidNameChars;
- for Index := Length(Info) downto 1 do
- System.Insert(Space, Info, Index);
- MessageBeep(MB_ICONHAND);
- if MessageDlg(SErrorInvalidName + Space + Info, mtError,
- [mbOK, mbAbort], 0) = mrOK then RetryRename(HItem.pszText);
- LoadEnabled := True;
- end
- else
- begin
- InternalEdit(HItem);
- end;
- end;
- end; {Edit}
- procedure TCustomDirView.EndSelectionUpdate;
- begin
- inherited;
- if FUpdatingSelection = 0 then
- DoUpdateStatusBar;
- end; { EndUpdatingSelection }
- procedure TCustomDirView.ExecuteCurrentFile;
- begin
- Assert(Assigned(ItemFocused));
- Execute(ItemFocused, False);
- end;
- function TCustomDirView.DoExecFile(Item: TListItem; ForceEnter: Boolean): Boolean;
- begin
- Result := True;
- if Assigned(FOnExecFile) then FOnExecFile(Self, Item, Result);
- end;
- procedure TCustomDirView.Execute(Item: TListItem; ForceEnter: Boolean);
- begin
- Assert(Assigned(Item));
- if Assigned(Item) and Assigned(Item.Data) and (not Loading) then
- begin
- if IsRecycleBin and (not ItemIsParentDirectory(Item)) then DisplayPropertiesMenu
- else
- if DoExecFile(Item, ForceEnter) then
- begin
- if ItemIsParentDirectory(Item) then ExecuteParentDirectory
- else ExecuteFile(Item);
- end;
- end;
- end;
- procedure TCustomDirView.GetDisplayInfo(ListItem: TListItem;
- var DispInfo: TLVItem);
- begin
- // Nothing
- end;
- procedure TCustomDirView.WMUserRename(var Message: TMessage);
- var
- Dummy: Boolean;
- begin
- if Assigned(ItemFocused) then
- begin
- FForceRename := True;
- ListView_EditLabel(Handle, ItemFocused.Index);
- SetWindowText(ListView_GetEditControl(Self.Handle),
- PChar(FLastRenameName));
- // This was called already by VCL.
- // But we do it again for the base-name selection side effect this has in TCustomScpExplorerForm::DirViewEditing,
- // after we have updated the text above.
- if Assigned(OnEditing) then
- OnEditing(Self, ItemFocused, Dummy);
- end;
- end;
- procedure TCustomDirView.RetryRename(NewName: string);
- begin
- FLastRenameName := NewName;
- PostMessage(Self.Handle, WM_USER_RENAME, Longint(PChar(NewName)), 0);
- end;
- procedure TCustomDirView.AddToDragFileList(FileList: TFileList; Item: TListItem);
- begin
- FileList.AddItem(nil, ItemFullFileName(Item));
- end;
- procedure TCustomDirView.DDDragDetect(grfKeyState: Integer; DetectStart,
- Point: TPoint; DragStatus: TDragDetectStatus);
- var
- FilesCount: Integer;
- DirsCount: Integer;
- Item: TListItem;
- FirstItem : TListItem;
- Bitmap: TBitmap;
- ImageListHandle: HImageList;
- Spot: TPoint;
- ItemPos: TPoint;
- DragText: string;
- ClientPoint: TPoint;
- FileListCreated: Boolean;
- AvoidDragImage: Boolean;
- DataObject: TDataObject;
- begin
- if Assigned(FOnDDDragDetect) then
- FOnDDDragDetect(Self, grfKeyState, DetectStart, Point, DragStatus);
- FLastDDResult := drCancelled;
- if (DragStatus = ddsDrag) and (not Loading) and (MarkedCount > 0) then
- begin
- DragDropFilesEx.CompleteFileList := DragCompleteFileList;
- DragDropFilesEx.FileList.Clear;
- FirstItem := nil;
- FilesCount := 0;
- DirsCount := 0;
- FileListCreated := False;
- AvoidDragImage := False;
- if Assigned(OnDDCreateDragFileList) then
- begin
- OnDDCreateDragFileList(Self, DragDropFilesEx.FileList, FileListCreated);
- if FileListCreated then
- begin
- AvoidDragImage := True;
- end;
- end;
- if not FileListCreated then
- begin
- if Assigned(ItemFocused) and (not ItemFocused.Selected) then
- begin
- if ItemCanDrag(ItemFocused) then
- begin
- FirstItem := ItemFocused;
- AddToDragFileList(DragDropFilesEx.FileList, ItemFocused);
- if ItemIsDirectory(ItemFocused) then Inc(DirsCount)
- else Inc(FilesCount);
- end;
- end
- else
- if SelCount > 0 then
- begin
- Item := GetNextItem(nil, sdAll, [isSelected]);
- while Assigned(Item) do
- begin
- if ItemCanDrag(Item) then
- begin
- if not Assigned(FirstItem) then FirstItem := Item;
- AddToDragFileList(DragDropFilesEx.FileList, Item);
- if ItemIsDirectory(Item) then Inc(DirsCount)
- else Inc(FilesCount);
- end;
- Item := GetNextItem(Item, sdAll, [isSelected]);
- end;
- end;
- end;
- if DragDropFilesEx.FileList.Count > 0 then
- begin
- FDragEnabled := False;
- {Create the dragimage:}
- GlobalDragImageList := DragImageList;
- // This code is not used anymore
- if UseDragImages and (not AvoidDragImage) then
- begin
- ImageListHandle := ListView_CreateDragImage(Handle, FirstItem.Index, Spot);
- ItemPos := ClientToScreen(FirstItem.DisplayRect(drBounds).TopLeft);
- if ImageListHandle <> Invalid_Handle_Value then
- begin
- GlobalDragImageList.Handle := ImageListHandle;
- if FilesCount + DirsCount = 1 then
- begin
- ItemPos := ClientToScreen(FirstItem.DisplayRect(drBounds).TopLeft);
- GlobalDragImageList.SetDragImage(0,
- DetectStart.X - ItemPos.X, DetectStart.Y - ItemPos.Y);
- end
- else
- begin
- GlobalDragImageList.Clear;
- GlobalDragImageList.Width := 32;
- GlobalDragImageList.Height := 32;
- if GlobalDragImageList.GetResource(rtBitMap, 'DRAGFILES', 0,
- [lrTransparent], $FFFFFF) Then
- begin
- Bitmap := TBitmap.Create;
- try
- try
- GlobalDragImageList.GetBitmap(0, Bitmap);
- Bitmap.Canvas.Font.Assign(Self.Font);
- DragText := '';
- if FilesCount > 0 then
- DragText := Format(STextFiles, [FilesCount]);
- if DirsCount > 0 then
- begin
- if FilesCount > 0 then
- DragText := DragText + ', ';
- DragText := DragText + Format(STextDirectories, [DirsCount]);
- end;
- Bitmap.Width := 33 + Bitmap.Canvas.TextWidth(DragText);
- Bitmap.TransparentMode := tmAuto;
- Bitmap.Canvas.TextOut(33,
- Max(24 - Abs(Canvas.Font.Height), 0), DragText);
- GlobalDragImageList.Clear;
- GlobalDragImageList.Width := Bitmap.Width;
- GlobalDragImageList.AddMasked(Bitmap,
- Bitmap.Canvas.Pixels[0, 0]);
- GlobalDragImageList.SetDragImage(0, 25, 20);
- except
- if GlobalDragImageList.GetResource(rtBitMap, 'DRAGFILES',
- 0, [lrTransparent], $FFFFFF) then
- GlobalDragImageList.SetDragImage(0, 25, 20);
- end;
- finally
- Bitmap.Free;
- end;
- end;
- end;
- ClientPoint := ParentForm.ScreenToClient(Point);
- GlobalDragImageList.BeginDrag(ParentForm.Handle,
- ClientPoint.X, ClientPoint.Y);
- GlobalDragImageList.HideDragImage;
- ShowCursor(True);
- end;
- end;
- FContextMenu := False;
- if IsRecycleBin then DragDropFilesEx.SourceEffects := [deMove]
- else DragDropFilesEx.SourceEffects := DragSourceEffects;
- DropSourceControl := Self;
- try
- GetSystemTimeAsFileTime(FDragStartTime);
- DataObject := nil;
- if Assigned(OnDDCreateDataObject) then
- begin
- OnDDCreateDataObject(Self, DataObject);
- end;
- {Execute the drag&drop-Operation:}
- FLastDDResult := DragDropFilesEx.Execute(DataObject);
- // The drag&drop operation is finished, so clean up the used drag image.
- // This also restores the default mouse cursor
- // (which is set to "none" in GlobalDragImageList.BeginDrag above)
- // But it's actually too late, we would need to do it when mouse button
- // is realesed already. Otherwise the cursor is hidden when hovering over
- // main window, while target application is processing dropped file
- // (particularly when Explorer displays progress window or
- // overwrite confirmation prompt)
- GlobalDragImageList.EndDrag;
- GlobalDragImageList.Clear;
- Application.ProcessMessages;
- finally
- DragDropFilesEx.FileList.Clear;
- FContextMenu := False;
- try
- if Assigned(OnDDEnd) then
- OnDDEnd(Self);
- finally
- DropTarget := nil;
- DropSourceControl := nil;
- end;
- end;
- end;
- end;
- end;
- procedure TCustomDirView.Notification(AComponent: TComponent; Operation: TOperation);
- begin
- inherited;
- if Operation = opRemove then
- begin
- if AComponent = PathLabel then FPathLabel := nil;
- end;
- end; { Notification }
- procedure TCustomDirView.WMAppCommand(var Message: TMessage);
- var
- Command: Integer;
- Shift: TShiftState;
- begin
- Command := HiWord(Message.lParam) and (not FAPPCOMMAND_MASK);
- Shift := KeyDataToShiftState(HiWord(Message.lParam) and FAPPCOMMAND_MASK);
- if Shift * [ssShift, ssAlt, ssCtrl] = [] then
- begin
- if Command = APPCOMMAND_BROWSER_BACKWARD then
- begin
- Message.Result := 1;
- if BackCount >= 1 then DoHistoryGo(-1);
- end
- else
- if Command = APPCOMMAND_BROWSER_FORWARD then
- begin
- Message.Result := 1;
- if ForwardCount >= 1 then DoHistoryGo(1);
- end
- else
- if Command = APPCOMMAND_BROWSER_REFRESH then
- begin
- Message.Result := 1;
- BusyOperation(ReloadDirectory);
- end
- else
- if Command = APPCOMMAND_BROWSER_HOME then
- begin
- Message.Result := 1;
- BusyOperation(ExecuteHomeDirectory);
- end
- else inherited;
- end
- else inherited;
- end;
- procedure TCustomDirView.CMColorChanged(var Message: TMessage);
- begin
- inherited;
- ForceColorChange(Self);
- end;
- function TCustomDirView.FindFileItemIfNotEmpty(FileName: string): TListItem;
- begin
- Result := nil;
- if FileName <> '' then
- Result := FindFileItem(FileName);
- end;
- function TCustomDirView.FindFileItem(FileName: string): TListItem;
- type
- TFileNameCompare = function(const S1, S2: string): Integer;
- var
- Index: Integer;
- CompareFunc: TFileNameCompare;
- begin
- if FCaseSensitive then CompareFunc := CompareStr
- else CompareFunc := CompareText;
- // Optimization to avoid duplicate lookups in consequent RestoreFocus calls from Load and RestoreState.
- if Assigned(ItemFocused) and (CompareFunc(FileName, ItemFileName(ItemFocused)) = 0) then
- begin
- Result := ItemFocused;
- Exit;
- end
- else
- begin
- for Index := 0 to Items.Count - 1 do
- begin
- if CompareFunc(FileName, ItemFileName(Items[Index])) = 0 then
- begin
- Result := Items[Index];
- Exit;
- end;
- end;
- end;
- Result := nil;
- end;
- function TCustomDirView.GetForwardCount: Integer;
- begin
- Result := FHistoryPaths.Count - BackCount;
- end; { GetForwardCount }
- procedure TCustomDirView.LimitHistorySize;
- begin
- while FHistoryPaths.Count > MaxHistoryCount do
- begin
- if BackCount > 0 then
- begin
- FHistoryPaths.Delete(0);
- Dec(FBackCount);
- end
- else
- FHistoryPaths.Delete(FHistoryPaths.Count-1);
- end;
- end; { LimitHistorySize }
- function TCustomDirView.GetHistoryPath(Index: Integer): string;
- begin
- Assert(Assigned(FHistoryPaths));
- if Index = 0 then Result := PathName
- else
- if Index < 0 then Result := FHistoryPaths[Index + BackCount]
- else
- if Index > 0 then Result := FHistoryPaths[Index + BackCount - 1];
- end; { GetHistoryPath }
- procedure TCustomDirView.SetMaxHistoryCount(Value: Integer);
- begin
- if FMaxHistoryCount <> Value then
- begin
- FMaxHistoryCount := Value;
- DoHistoryChange;
- end;
- end; { SetMaxHistoryCount }
- procedure TCustomDirView.DoHistoryChange;
- begin
- LimitHistorySize;
- if Assigned(OnHistoryChange) then
- OnHistoryChange(Self);
- end; { DoHistoryChange }
- procedure TCustomDirView.DoHistoryGo(Index: Integer);
- var
- Cancel: Boolean;
- begin
- if StartBusy then
- try
- Cancel := False;
- if Assigned(OnHistoryGo) then
- OnHistoryGo(Self, Index, Cancel);
- if not Cancel then HistoryGo(Index);
- finally
- EndBusy;
- end;
- end;
- procedure TCustomDirView.HistoryGo(Index: Integer);
- var
- PrevPath: string;
- begin
- if Index <> 0 then
- begin
- PrevPath := FHistoryPath;
- FDontRecordPath := True;
- try
- Path := HistoryPath[Index];
- finally
- FDontRecordPath := False;
- end;
- FHistoryPaths.Insert(FBackCount, PrevPath);
- FHistoryPaths.Delete(Index + BackCount);
- Inc(FBackCount, Index);
- DoHistoryChange;
- end;
- end; { HistoryGo }
- procedure TCustomDirView.PathChanging(Relative: Boolean);
- begin
- if Relative then FLastPath := PathName
- else FLastPath := '';
- FSavedNames.Clear;
- end;
- procedure TCustomDirView.PathChanged;
- var
- Index: Integer;
- begin
- if Assigned(OnPathChange) then
- OnPathChange(Self);
- if (not FDontRecordPath) and (FHistoryPath <> '') and (FHistoryPath <> PathName) then
- begin
- Assert(Assigned(FHistoryPaths));
- for Index := FHistoryPaths.Count - 1 downto BackCount do
- FHistoryPaths.Delete(Index);
- FHistoryPaths.Add(FHistoryPath);
- Inc(FBackCount);
- DoHistoryChange;
- end;
- FHistoryPath := PathName;
- end; { PathChanged }
- procedure TCustomDirView.ProcessChangedFiles(DirView: TCustomDirView;
- FileList: TStrings; FullPath: Boolean; ExistingOnly: Boolean;
- Criterias: TCompareCriterias);
- var
- Item, MirrorItem: TListItem;
- FileTime, MirrorFileTime: TDateTime;
- OldCursor: TCursor;
- Index: Integer;
- Changed: Boolean;
- SameTime: Boolean;
- Precision, MirrorPrecision: TDateTimePrecision;
- begin
- Assert(Valid);
- OldCursor := Screen.Cursor;
- if not Assigned(FileList) then
- begin
- Items.BeginUpdate;
- BeginSelectionUpdate;
- end;
- try
- Screen.Cursor := crHourGlass;
- for Index := 0 to Items.Count-1 do
- begin
- Item := Items[Index];
- Changed := False;
- if not ItemIsDirectory(Item) then
- begin
- MirrorItem := DirView.FindFileItem(ItemFileName(Item));
- if MirrorItem = nil then
- begin
- Changed := not ExistingOnly;
- end
- else
- begin
- if ccTime in Criterias then
- begin
- FileTime := ItemFileTime(Item, Precision);
- MirrorFileTime := DirView.ItemFileTime(MirrorItem, MirrorPrecision);
- if MirrorPrecision < Precision then Precision := MirrorPrecision;
- if Precision <> tpMillisecond then
- begin
- ReduceDateTimePrecision(FileTime, Precision);
- ReduceDateTimePrecision(MirrorFileTime, Precision);
- end;
- SameTime := (FileTime = MirrorFileTime);
- if Precision = tpSecond then
- begin
- // 1 ms more solves the rounding issues
- // (see also Common.cpp)
- MirrorFileTime := MirrorFileTime + EncodeTime(0, 0, 1, 1);
- end;
- Changed :=
- (FileTime > MirrorFileTime);
- end
- else
- begin
- SameTime := True;
- end;
- if (not Changed) and SameTime and (ccSize in Criterias) then
- begin
- Changed := ItemFileSize(Item) <> DirView.ItemFileSize(MirrorItem);
- end
- end;
- end;
- if Assigned(FileList) then
- begin
- if Changed then
- begin
- if FullPath then
- begin
- FileList.AddObject(ItemFullFileName(Item), Item.Data)
- end
- else
- begin
- FileList.AddObject(ItemFileName(Item), Item.Data);
- end;
- end;
- end
- else
- begin
- Item.Selected := Changed;
- end;
- end;
- finally
- Screen.Cursor := OldCursor;
- if not Assigned(FileList) then
- begin
- Items.EndUpdate;
- EndSelectionUpdate;
- end;
- end;
- end;
- function TCustomDirView.CreateChangedFileList(DirView: TCustomDirView;
- FullPath: Boolean; ExistingOnly: Boolean; Criterias: TCompareCriterias): TStrings;
- begin
- Result := TStringList.Create;
- try
- ProcessChangedFiles(DirView, Result, FullPath, ExistingOnly, Criterias);
- except
- FreeAndNil(Result);
- raise;
- end;
- end;
- function TCustomDirView.CanPasteFromClipBoard: Boolean;
- begin
- Result := False;
- if DirOK and (Path <> '') and Windows.OpenClipboard(0) then
- begin
- Result := IsClipboardFormatAvailable(CF_HDROP);
- Windows.CloseClipBoard;
- end;
- end; {CanPasteFromClipBoard}
- procedure TCustomDirView.CompareFiles(DirView: TCustomDirView;
- ExistingOnly: Boolean; Criterias: TCompareCriterias);
- begin
- ProcessChangedFiles(DirView, nil, True, ExistingOnly, Criterias);
- end;
- function TCustomDirView.GetColumnText(ListItem: TListItem; Index: Integer): string;
- var
- DispInfo: TLVItem;
- begin
- FillChar(DispInfo, SizeOf(DispInfo), 0);
- DispInfo.Mask := LVIF_TEXT;
- DispInfo.iSubItem := Index;
- DispInfo.cchTextMax := 260;
- SetLength(Result, DispInfo.cchTextMax);
- DispInfo.pszText := PChar(Result);
- GetDisplayInfo(ListItem, DispInfo);
- SetLength(Result, StrLen(PChar(Result)));
- end;
- procedure TCustomDirView.FocusSomething(ForceMakeVisible: Boolean);
- begin
- if FSavedSelection then
- begin
- if ForceMakeVisible then FPendingFocusSomething := 1
- else FPendingFocusSomething := 0
- end
- else inherited;
- end;
- procedure TCustomDirView.SaveSelection;
- var
- Closest: TListItem;
- begin
- Assert(not FSavedSelection);
- FSavedSelectionFile := '';
- FSavedSelectionLastFile := '';
- if Assigned(ItemFocused) then
- begin
- FSavedSelectionLastFile := ItemFocused.Caption;
- end;
- Closest := ClosestUnselected(ItemFocused);
- if Assigned(Closest) then
- begin
- FSavedSelectionFile := Closest.Caption;
- end;
- FSavedSelection := True;
- end;
- procedure TCustomDirView.RestoreSelection;
- var
- ItemToSelect: TListItem;
- begin
- Assert(FSavedSelection);
- FSavedSelection := False;
- if (FSavedSelectionLastFile <> '') and
- ((not Assigned(ItemFocused)) or
- (ItemFocused.Caption <> FSavedSelectionLastFile)) then
- begin
- ItemToSelect := FindFileItem(FSavedSelectionFile);
- if Assigned(ItemToSelect) then
- begin
- ItemFocused := ItemToSelect;
- end;
- end;
- if not Assigned(ItemFocused) then FocusSomething(True)
- else ItemFocused.MakeVisible(False);
- end;
- procedure TCustomDirView.DiscardSavedSelection;
- begin
- Assert(FSavedSelection);
- FSavedSelection := False;
- if FPendingFocusSomething >= 0 then
- begin
- FocusSomething(FPendingFocusSomething > 0);
- FPendingFocusSomething := -1;
- end;
- end;
- procedure TCustomDirView.SaveSelectedNames;
- var
- Index: Integer;
- Item: TListItem;
- begin
- FSavedNames.Clear;
- FSavedNames.CaseSensitive := FCaseSensitive;
- if SelCount > 0 then // optimalisation
- begin
- for Index := 0 to Items.Count-1 do
- begin
- Item := Items[Index];
- if Item.Selected then
- FSavedNames.Add(ItemFileName(Item));
- end;
- end;
- // as optimalisation the list is sorted only when the selection is restored
- end;
- procedure TCustomDirView.RestoreSelectedNames;
- var
- Index, FoundIndex: Integer;
- Item: TListItem;
- begin
- FSavedNames.Sort;
- for Index := 0 to Items.Count - 1 do
- begin
- Item := Items[Index];
- Item.Selected := FSavedNames.Find(ItemFileName(Item), FoundIndex);
- end;
- end;
- function TCustomDirView.GetSelectedNamesSaved: Boolean;
- begin
- Result := (FSavedNames.Count > 0);
- end;
- procedure TCustomDirView.ContinueSession(Continue: Boolean);
- begin
- if Continue then FLastPath := PathName
- else FLastPath := '';
- end;
- procedure TCustomDirView.AnnounceState(AState: TObject);
- var
- State: TDirViewState;
- begin
- FAnnouncedState := AState;
- if Assigned(FAnnouncedState) then
- begin
- State := AState as TDirViewState;
- if Assigned(State) then
- begin
- FEffectiveMask := State.Mask;
- end;
- end
- else
- begin
- FEffectiveMask := Mask;
- end;
- end;
- procedure TCustomDirView.SaveItemsState(
- var FocusedItem: string; var FocusedShown: Boolean; var ShownItemOffset: Integer);
- begin
- if Assigned(ItemFocused) then
- begin
- if ViewStyle = vsReport then
- begin
- if Assigned(TopItem) then
- begin
- FocusedShown := IsItemVisible(ItemFocused);
- if not FocusedShown then
- begin
- ShownItemOffset := TopItem.Index;
- end
- else
- begin
- ShownItemOffset := ItemFocused.Index - TopItem.Index;
- end;
- end
- else
- begin
- // seen with one user only
- FocusedShown := False;
- ShownItemOffset := 0;
- end;
- end
- else
- begin
- // to satisfy compiler, never used
- FocusedShown := False;
- ShownItemOffset := -1;
- end;
- FocusedItem := ItemFocused.Caption;
- end
- else
- begin
- FocusedItem := '';
- FocusedShown := False;
- if Assigned(TopItem) then ShownItemOffset := TopItem.Index
- else ShownItemOffset := -1;
- end;
- end;
- procedure TCustomDirView.RestoreItemsState(ItemToFocus: TListItem; FocusedShown: Boolean; ShownItemOffset: Integer);
- begin
- if Assigned(ItemToFocus) then
- begin
- // we have found item that was previously focused and visible, scroll to it
- if (ViewStyle = vsReport) and FocusedShown and
- (ItemToFocus.Index > ShownItemOffset) then
- begin
- MakeTopItem(Items[ItemToFocus.Index - ShownItemOffset]);
- end;
- // Strangely after this mouse selection works correctly, so we do not have to call FocusItem.
- ItemFocused := ItemToFocus;
- end;
- // previously focused item was not visible, scroll to the same position
- // as before
- if (ViewStyle = vsReport) and (not FocusedShown) and
- (ShownItemOffset >= 0) and (Items.Count > 0) then
- begin
- if ShownItemOffset < Items.Count - VisibleRowCount then
- MakeTopItem(Items[ShownItemOffset])
- else
- Items.Item[Items.Count - 1].MakeVisible(false);
- end
- // do not know where to scroll to, so scroll to focus
- // (or we have tried to scroll to previously focused and visible item,
- // now make sure that it is really visible)
- else
- if Assigned(ItemToFocus) then ItemToFocus.MakeVisible(False);
- end;
- procedure TCustomDirView.RestoreItemsState(AState: TObject);
- var
- State: TDirViewState;
- ItemToFocus: TListItem;
- begin
- State := TDirViewState(AState);
- ItemToFocus := FindFileItemIfNotEmpty(State.FocusedItem);
- RestoreItemsState(ItemToFocus, State.FocusedShown, State.ShownItemOffset);
- end;
- function TCustomDirView.SaveState: TObject;
- var
- State: TDirViewState;
- DirColProperties: TCustomDirViewColProperties;
- begin
- State := TDirViewState.Create;
- State.HistoryPaths := TStringList.Create;
- State.HistoryPaths.Assign(FHistoryPaths);
- State.BackCount := FBackCount;
- // TCustomDirViewColProperties should not be here
- DirColProperties := ColProperties as TCustomDirViewColProperties;
- Assert(Assigned(DirColProperties));
- State.SortStr := DirColProperties.SortStr;
- State.Mask := Mask;
- SaveItemsState(State.FocusedItem, State.FocusedShown, State.ShownItemOffset);
- Result := State;
- end;
- procedure TCustomDirView.FocusByName(FileName: string);
- var
- ListItem: TListItem;
- begin
- ListItem := FindFileItemIfNotEmpty(FileName);
- if Assigned(ListItem) then
- begin
- ItemFocused := ListItem;
- ListItem.MakeVisible(False);
- end;
- end;
- procedure TCustomDirView.RestoreState(AState: TObject);
- var
- State: TDirViewState;
- DirColProperties: TCustomDirViewColProperties;
- begin
- if Assigned(AState) then
- begin
- Assert(AState is TDirViewState);
- State := AState as TDirViewState;
- Assert(Assigned(State));
- Assert((not Assigned(FAnnouncedState)) or (FAnnouncedState = AState));
- FHistoryPaths.Assign(State.HistoryPaths);
- FBackCount := State.BackCount;
- DoHistoryChange;
- // TCustomDirViewColProperties should not be here
- DirColProperties := ColProperties as TCustomDirViewColProperties;
- Assert(Assigned(DirColProperties));
- DirColProperties.SortStr := State.SortStr;
- Mask := State.Mask;
- RestoreItemsState(State);
- end
- else
- begin
- FHistoryPaths.Clear;
- FBackCount := 0;
- DoHistoryChange;
- end;
- end;
- procedure TCustomDirView.SetMask(Value: string);
- begin
- if Mask <> Value then
- begin
- if Assigned(FAnnouncedState) then
- Assert(FEffectiveMask = Value)
- else
- Assert(FEffectiveMask = Mask);
- FMask := Value;
- UpdatePathLabel;
- if FEffectiveMask <> Value then
- begin
- FEffectiveMask := Value;
- if DirOK then Reload(False);
- end;
- end;
- end;{SetMask}
- procedure TCustomDirView.SetNaturalOrderNumericalSorting(Value: Boolean);
- begin
- if NaturalOrderNumericalSorting <> Value then
- begin
- FNaturalOrderNumericalSorting := Value;
- SortItems;
- end;
- end;
- procedure TCustomDirView.SetAlwaysSortDirectoriesByName(Value: Boolean);
- begin
- if AlwaysSortDirectoriesByName <> Value then
- begin
- FAlwaysSortDirectoriesByName := Value;
- SortItems;
- end;
- end;
- procedure TCustomDirView.SetDarkMode(Value: Boolean);
- begin
- if DarkMode <> Value then
- begin
- FDarkMode := Value;
- // Call only when switching to dark more and when switching back to the light mode.
- // But not for initial light mode - To reduce an impact of calling an undocumented function.
- if HandleAllocated then UpdateDarkMode;
- end;
- end;
- // WM_SETFOCUS works even when focus is moved to another window/app,
- // while .Enter works only when focus is moved to other control of the same window.
- procedure TCustomDirView.WMSetFocus(var Message: TWMSetFocus);
- begin
- inherited;
- EnsureSelectionRedrawn;
- UpdatePathLabel;
- end;
- procedure TCustomDirView.WMKillFocus(var Message: TWMKillFocus);
- begin
- inherited;
- EnsureSelectionRedrawn;
- UpdatePathLabel;
- end;
- procedure TCustomDirView.EnsureSelectionRedrawn;
- begin
- // WORKAROUND
- // when receiving/losing focus, selection is not redrawn in report view
- // (except for focus item selection),
- // probably when double buffering is enabled (LVS_EX_DOUBLEBUFFER).
- // But even without LVS_EX_DOUBLEBUFFER, selection behind file icon is not updated.
- if ViewStyle = vsReport then
- begin
- if (SelCount >= 2) or ((SelCount >= 1) and ((not Assigned(ItemFocused)) or (not ItemFocused.Selected))) then
- begin
- Invalidate;
- end
- else
- if Assigned(ItemFocused) and ItemFocused.Selected then
- begin
- // Optimization. When no item is selected, redraw just the focused item.
- ItemFocused.Update;
- end;
- end;
- end;
- function TCustomDirView.DoBusy(Busy: Integer): Boolean;
- begin
- Result := True;
- if Assigned(OnBusy) then
- begin
- OnBusy(Self, Busy, Result);
- end;
- end;
- function TCustomDirView.StartBusy: Boolean;
- begin
- Result := DoBusy(1);
- end;
- function TCustomDirView.IsBusy: Boolean;
- begin
- Result := DoBusy(0);
- end;
- procedure TCustomDirView.EndBusy;
- begin
- DoBusy(-1);
- end;
- procedure TCustomDirView.BusyOperation(Operation: TBusyOperation);
- begin
- if StartBusy then
- try
- Operation;
- finally
- EndBusy;
- end;
- end;
- procedure TCustomDirView.ItemCalculatedSizeUpdated(Item: TListItem; OldSize, NewSize: Int64);
- begin
- if OldSize >= 0 then
- begin
- Dec(FFilesSize, OldSize);
- if Item.Selected then Dec(FFilesSelSize, OldSize);
- end;
- if NewSize >= 0 then
- begin
- Inc(FFilesSize, NewSize);
- if Item.Selected then Inc(FFilesSelSize, NewSize);
- end;
- Item.Update;
- UpdateStatusBar;
- end;
- function TCustomDirView.GetDirViewStyle: TDirViewStyle;
- begin
- if (ViewStyle = vsIcon) and FThumbnail then Result := dvsThumbnail
- else Result := TDirViewStyle(ViewStyle);
- end;
- procedure TCustomDirView.SetDirViewStyle(Value: TDirViewStyle);
- var
- NewViewStyle: TViewStyle;
- begin
- if DirViewStyle <> Value then
- begin
- FThumbnail := (Value = dvsThumbnail);
- // Create thumbnail images before recreating the view
- NeedImageLists(False);
- if FThumbnail then NewViewStyle := vsIcon
- else NewViewStyle := TViewStyle(Value);
- if ViewStyle <> NewViewStyle then
- begin
- ViewStyle := NewViewStyle;
- end
- else
- begin
- // Changing ViewStyle recreates the view, we want to be consistent.
- if not (csLoading in ComponentState) then
- begin
- RecreateWnd;
- end;
- // Again, for consistency (among other this clears thumbnail cache)
- ViewStyleChanged;
- end;
- end;
- end;
- procedure TCustomDirView.InvalidateItem(Item: TListItem);
- var
- R: TRect;
- begin
- R := Item.DisplayRect(drBounds);
- // alternative to TListItem.Update (which causes flicker)
- InvalidateRect(Handle, @R, True);
- end;
- procedure TCustomDirView.WMUserInvalidateItem(var Message: TMessage);
- var
- Index: Integer;
- begin
- Index := Integer(Message.WParam);
- if (Index >= 0) and (Index < Items.Count) then
- InvalidateItem(Items[Index]);
- end;
- initialization
- DropSourceControl := nil;
- SetLength(WinDir, MAX_PATH);
- SetLength(WinDir, GetWindowsDirectory(PChar(WinDir), MAX_PATH));
- SetLength(TempDir, MAX_PATH);
- SetLength(TempDir, GetTempPath(MAX_PATH, PChar(TempDir)));
- SpecialFolderLocation(CSIDL_PERSONAL, UserDocumentDirectory);
- WinDir := IncludeTrailingPathDelimiter(WinDir);
- TempDir := IncludeTrailingPathDelimiter(TempDir);
- finalization
- SetLength(StdDirTypeName, 0);
- SetLength(WinDir, 0);
- SetLength(TempDir, 0);
- end.
|