PathLabel.pas 22 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850
  1. unit PathLabel;
  2. interface
  3. {$WARN UNIT_PLATFORM OFF}
  4. uses
  5. Messages, StdCtrls, Controls, Classes, Forms, Windows, Graphics;
  6. type
  7. TCustomPathLabel = class;
  8. TPathLabelGetStatusEvent = procedure(Sender: TCustomPathLabel; var Active: Boolean) of object;
  9. TPathLabelPathClickEvent = procedure(Sender: TCustomPathLabel; Path: string) of object;
  10. TCustomPathLabel = class(TCustomLabel)
  11. private
  12. FColors: array[0..5] of TColor;
  13. FIndentHorizontal: Integer;
  14. FIndentVertical: Integer;
  15. FUnixPath: Boolean;
  16. FOnGetStatus: TPathLabelGetStatusEvent;
  17. FOnPathClick: TPathLabelPathClickEvent;
  18. FDisplayPath: string;
  19. FDisplayHotTrack: string;
  20. FDisplayMask: string;
  21. FHotTrack: Boolean;
  22. FMouseInView: Boolean;
  23. FIsActive: Boolean;
  24. FIsEnabled: Boolean;
  25. FMask: string;
  26. FAutoSizeVertical: Boolean;
  27. procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  28. procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
  29. procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
  30. function GetColors(Index: Integer): TColor;
  31. procedure SetColors(Index: Integer; Value: TColor);
  32. procedure SetIndentHorizontal(AIndent: Integer);
  33. procedure SetIndentVertical(AIndent: Integer);
  34. procedure SetUnixPath(AUnixPath: Boolean);
  35. procedure SetMask(Value: string);
  36. procedure SetAutoSizeVertical(Value: Boolean);
  37. procedure SetFocusControl(Value: TWinControl);
  38. function GetFocusControl: TWinControl;
  39. function CalculateAutoHotTrackColor(C: TColor): TColor;
  40. procedure CalculateAutoHotTrackColors;
  41. function CalculateAutoHotTrackColorComponent(C: Byte; Bright: Boolean): Byte;
  42. function UseHotTrack: Boolean;
  43. protected
  44. procedure AdjustBounds; override;
  45. procedure Click; override;
  46. procedure DoDrawTextIntern(var Rect: TRect; Flags: Longint; S: string);
  47. procedure DoDrawText(var Rect: TRect; Flags: Longint); override;
  48. procedure Notification(AComponent: TComponent;
  49. Operation: TOperation); override;
  50. procedure Paint; override;
  51. function IsActive: Boolean;
  52. function TrackingActive: Boolean;
  53. function HotTrackPath(Path: string): string;
  54. procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override;
  55. procedure DoPathClick(Path: string); virtual;
  56. procedure DblClick; override;
  57. procedure DoContextPopup(MousePos: TPoint; var Handled: Boolean); override;
  58. public
  59. constructor Create(AnOwner: TComponent); override;
  60. procedure UpdateStatus;
  61. function UseRightToLeftAlignment: Boolean; override;
  62. property ActiveColor: TColor index 1 read GetColors write SetColors
  63. default clActiveCaption;
  64. property ActiveTextColor: TColor index 3 read GetColors write SetColors
  65. default clCaptionText;
  66. property UnixPath: Boolean read FUnixPath write SetUnixPath default False;
  67. property IndentHorizontal: Integer read FIndentHorizontal
  68. write SetIndentHorizontal default 5;
  69. property IndentVertical: Integer read FIndentVertical
  70. write SetIndentVertical default 1;
  71. property InactiveColor: TColor index 0 read GetColors write SetColors
  72. default clInactiveCaption;
  73. property InactiveTextColor: TColor index 2 read GetColors write SetColors
  74. default clInactiveCaptionText;
  75. property OnGetStatus: TPathLabelGetStatusEvent read FOnGetStatus write FOnGetStatus;
  76. property OnPathClick: TPathLabelPathClickEvent read FOnPathClick write FOnPathClick;
  77. property HotTrack: Boolean read FHotTrack write FHotTrack default False;
  78. property Mask: string read FMask write SetMask;
  79. property AutoSizeVertical: Boolean read FAutoSizeVertical write SetAutoSizeVertical default False;
  80. property FocusControl: TWinControl read GetFocusControl write SetFocusControl;
  81. property Caption;
  82. property Hint stored False;
  83. property Align default alTop;
  84. end;
  85. type
  86. TPathLabel = class(TCustomPathLabel)
  87. published
  88. property ActiveColor;
  89. property ActiveTextColor;
  90. property UnixPath;
  91. property IndentHorizontal;
  92. property IndentVertical;
  93. property InactiveColor;
  94. property InactiveTextColor;
  95. property AutoSizeVertical;
  96. property HotTrack;
  97. property OnGetStatus;
  98. property OnPathClick;
  99. property Align;
  100. property Alignment;
  101. property Anchors;
  102. property AutoSize;
  103. property BiDiMode;
  104. property Constraints;
  105. property DragCursor;
  106. property DragKind;
  107. property DragMode;
  108. property Enabled;
  109. property Font;
  110. property ParentBiDiMode;
  111. property ParentFont;
  112. property PopupMenu;
  113. property Transparent;
  114. property Visible;
  115. property OnClick;
  116. property OnDblClick;
  117. property OnDragDrop;
  118. property OnDragOver;
  119. property OnEndDock;
  120. property OnEndDrag;
  121. property OnMouseDown;
  122. property OnMouseMove;
  123. property OnMouseUp;
  124. property OnStartDock;
  125. property OnStartDrag;
  126. end;
  127. procedure Register;
  128. implementation
  129. uses
  130. { SysUtils must overload deprecated FileCtrl (implements MinimizeName) }
  131. FileCtrl, SysUtils, Math;
  132. procedure Register;
  133. begin
  134. RegisterComponents('Martin', [TPathLabel]);
  135. end;
  136. { TCustomPathLabel }
  137. constructor TCustomPathLabel.Create(AnOwner: TComponent);
  138. begin
  139. inherited Create(AnOwner);
  140. WordWrap := False;
  141. Align := alTop;
  142. ShowAccelChar := False;
  143. FIndentHorizontal := 5;
  144. FIndentVertical := 1;
  145. FUnixPath := False;
  146. FHotTrack := False;
  147. FColors[0] := clInactiveCaption;
  148. FColors[1] := clActiveCaption;
  149. FColors[2] := clInactiveCaptionText;
  150. FColors[3] := clCaptionText;
  151. FIsEnabled := True;
  152. CalculateAutoHotTrackColors;
  153. end;
  154. procedure TCustomPathLabel.CMHintShow(var Message: TMessage);
  155. begin
  156. with TCMHintShow(Message).HintInfo^ do
  157. begin
  158. HintPos.X := ClientOrigin.X + IndentHorizontal;
  159. HintPos.Y := ClientOrigin.Y + IndentVertical;
  160. if UseHotTrack then Inc(HintPos.Y, Height);
  161. end;
  162. end; { CMHintShow }
  163. procedure TCustomPathLabel.Click;
  164. var
  165. HotPath: string;
  166. RemainingPath: string;
  167. begin
  168. if FIsEnabled then
  169. begin
  170. HotPath := HotTrackPath(FDisplayPath);
  171. if HotPath <> '' then
  172. begin
  173. if FDisplayPath = Caption then DoPathClick(HotPath)
  174. else
  175. begin
  176. // Displayed path is shortened.
  177. // The below is based on knowledge in MinimizeName algorithm
  178. RemainingPath := Copy(FDisplayPath, Length(HotPath) + 1,
  179. Length(FDisplayPath) - Length(HotPath));
  180. if RemainingPath = Copy(Caption, Length(Caption) - Length(RemainingPath) + 1,
  181. Length(RemainingPath)) then
  182. begin
  183. DoPathClick(Copy(Caption, 1, Length(Caption) - Length(RemainingPath)));
  184. end
  185. else
  186. if HotPath = Copy(Caption, 1, Length(HotPath)) then
  187. begin
  188. DoPathClick(HotPath);
  189. end
  190. else Assert(False);
  191. end;
  192. end;
  193. if Assigned(FocusControl) then FocusControl.SetFocus;
  194. inherited;
  195. end;
  196. end; { Click }
  197. procedure TCustomPathLabel.SetUnixPath(AUnixPath: Boolean);
  198. begin
  199. if FUnixPath <> AUnixPath then
  200. begin
  201. FUnixPath := AUnixPath;
  202. AdjustBounds;
  203. Invalidate;
  204. end;
  205. end;
  206. procedure TCustomPathLabel.SetMask(Value: string);
  207. begin
  208. if FMask <> Value then
  209. begin
  210. FMask := Value;
  211. AdjustBounds;
  212. Invalidate;
  213. end;
  214. end;
  215. procedure TCustomPathLabel.SetColors(Index: integer; Value: TColor);
  216. begin
  217. Assert(Index in [0..3]);
  218. if FColors[Index] <> Value then
  219. begin
  220. FColors[Index] := Value;
  221. CalculateAutoHotTrackColors;
  222. UpdateStatus;
  223. end;
  224. end; { SetColors }
  225. // taken from PngImageListEditor
  226. const
  227. WeightR: single = 0.764706;
  228. WeightG: single = 1.52941;
  229. WeightB: single = 0.254902;
  230. function ColorDistance(C1, C2: Integer): Single;
  231. var
  232. DR, DG, DB: Integer;
  233. begin
  234. DR := (C1 and $FF) - (C2 and $FF);
  235. Result := Sqr(DR * WeightR);
  236. DG := (C1 shr 8 and $FF) - (C2 shr 8 and $FF);
  237. Result := Result + Sqr(DG * WeightG);
  238. DB := (C1 shr 16) - (C2 shr 16);
  239. Result := Result + Sqr(DB * WeightB);
  240. Result := Sqrt(Result);
  241. end;
  242. function GetAdjustedThreshold(BkgndIntensity, Threshold: Single): Single;
  243. begin
  244. if BkgndIntensity < 220 then
  245. Result := (2 - BkgndIntensity / 220) * Threshold
  246. else
  247. Result := Threshold;
  248. end;
  249. function IsContrastEnough(AColor, ABkgndColor: Integer; DoAdjustThreshold: Boolean; Threshold: Single): Boolean;
  250. begin
  251. if DoAdjustThreshold then
  252. Threshold := GetAdjustedThreshold(ColorDistance(ABkgndColor, $000000),
  253. Threshold);
  254. Result := ColorDistance(ABkgndColor, AColor) > Threshold;
  255. end;
  256. procedure AdjustContrast(var AColor: Integer; ABkgndColor: Integer; Threshold: Single);
  257. var
  258. X, Y, Z: Single;
  259. R, G, B: Single;
  260. RR, GG, BB: Integer;
  261. I1, I2, S, Q, W: Single;
  262. DoInvert: Boolean;
  263. begin
  264. I1 := ColorDistance(AColor, $000000);
  265. I2 := ColorDistance(ABkgndColor, $000000);
  266. Threshold := GetAdjustedThreshold(I2, Threshold);
  267. if I1 > I2 then
  268. DoInvert := I2 < 442 - Threshold
  269. else
  270. DoInvert := I2 < Threshold;
  271. X := (ABkgndColor and $FF) * WeightR;
  272. Y := (ABkgndColor shr 8 and $FF) * WeightG;
  273. Z := (ABkgndColor shr 16) * WeightB;
  274. R := (AColor and $FF) * WeightR;
  275. G := (AColor shr 8 and $FF) * WeightG;
  276. B := (AColor shr 16) * WeightB;
  277. if DoInvert then begin
  278. R := 195 - R;
  279. G := 390 - G;
  280. B := 65 - B;
  281. X := 195 - X;
  282. Y := 390 - Y;
  283. Z := 65 - Z;
  284. end;
  285. S := Sqrt(Sqr(B) + Sqr(G) + Sqr(R));
  286. if S < 0.01 then
  287. S := 0.01;
  288. Q := (R * X + G * Y + B * Z) / S;
  289. X := Q / S * R - X;
  290. Y := Q / S * G - Y;
  291. Z := Q / S * B - Z;
  292. W := Sqrt(Sqr(Threshold) - Sqr(X) - Sqr(Y) - Sqr(Z));
  293. R := (Q - W) * R / S;
  294. G := (Q - W) * G / S;
  295. B := (Q - W) * B / S;
  296. if DoInvert then begin
  297. R := 195 - R;
  298. G := 390 - G;
  299. B := 65 - B;
  300. end;
  301. if R < 0 then
  302. R := 0
  303. else if R > 195 then
  304. R := 195;
  305. if G < 0 then
  306. G := 0
  307. else if G > 390 then
  308. G := 390;
  309. if B < 0 then
  310. B := 0
  311. else if B > 65 then
  312. B := 65;
  313. RR := Trunc(R * (1 / WeightR) + 0.5);
  314. GG := Trunc(G * (1 / WeightG) + 0.5);
  315. BB := Trunc(B * (1 / WeightB) + 0.5);
  316. if RR > $FF then
  317. RR := $FF
  318. else if RR < 0 then
  319. RR := 0;
  320. if GG > $FF then
  321. GG := $FF
  322. else if GG < 0 then
  323. GG := 0;
  324. if BB > $FF then
  325. BB := $FF
  326. else if BB < 0 then
  327. BB := 0;
  328. AColor := (BB and $FF) shl 16 or (GG and $FF) shl 8 or (RR and $FF);
  329. end;
  330. procedure SetContrast(var Color: TColor; BkgndColor: TColor; Threshold: Integer);
  331. var
  332. T: Single;
  333. begin
  334. if Color < 0 then
  335. Color := GetSysColor(Color and $FF);
  336. if BkgndColor < 0 then
  337. BkgndColor := GetSysColor(BkgndColor and $FF);
  338. T := Threshold;
  339. if not IsContrastEnough(Color, BkgndColor, True, T) then
  340. AdjustContrast(Integer(Color), BkgndColor, T);
  341. end;
  342. function TCustomPathLabel.CalculateAutoHotTrackColorComponent(C: Byte; Bright: Boolean): Byte;
  343. var
  344. Delta: Byte;
  345. begin
  346. Delta := Max(Round(C * 0.3), 80);
  347. if Bright then
  348. Result := Byte(Max(Integer(C) - Delta, 0))
  349. else
  350. Result := Byte(Min(C + Delta, 255));
  351. end;
  352. function TCustomPathLabel.CalculateAutoHotTrackColor(C: TColor): TColor;
  353. var
  354. R, G, B: Byte;
  355. Bright: Boolean;
  356. begin
  357. C := ColorToRGB(C);
  358. R := GetRValue(C);
  359. G := GetGValue(C);
  360. B := GetBValue(C);
  361. Bright := (R + G + B) > (256 / 2 * 3);
  362. R := CalculateAutoHotTrackColorComponent(R, Bright);
  363. G := CalculateAutoHotTrackColorComponent(G, Bright);
  364. B := CalculateAutoHotTrackColorComponent(B, Bright);
  365. Result := RGB(R, G, B);
  366. end;
  367. procedure TCustomPathLabel.CalculateAutoHotTrackColors;
  368. begin
  369. FColors[4] := CalculateAutoHotTrackColor(FColors[2]);
  370. SetContrast(FColors[4], FColors[0], 50);
  371. FColors[5] := CalculateAutoHotTrackColor(FColors[3]);
  372. SetContrast(FColors[5], FColors[1], 50);
  373. end;
  374. procedure TCustomPathLabel.SetIndentHorizontal(AIndent: Integer);
  375. begin
  376. if FIndentHorizontal <> AIndent then
  377. begin
  378. FIndentHorizontal := AIndent;
  379. AdjustBounds;
  380. Invalidate;
  381. end;
  382. end;
  383. procedure TCustomPathLabel.SetIndentVertical(AIndent: Integer);
  384. begin
  385. if FIndentVertical <> AIndent then
  386. begin
  387. FIndentVertical := AIndent;
  388. AdjustBounds;
  389. Invalidate;
  390. end;
  391. end;
  392. procedure TCustomPathLabel.SetAutoSizeVertical(Value: Boolean);
  393. begin
  394. if FAutoSizeVertical <> Value then
  395. begin
  396. FAutoSizeVertical := Value;
  397. AdjustBounds;
  398. Invalidate;
  399. end;
  400. end;
  401. function TCustomPathLabel.GetFocusControl: TWinControl;
  402. begin
  403. Result := inherited FocusControl;
  404. end;
  405. procedure TCustomPathLabel.SetFocusControl(Value: TWinControl);
  406. begin
  407. if FocusControl <> Value then
  408. begin
  409. inherited FocusControl := Value;
  410. UpdateStatus;
  411. end;
  412. end;
  413. procedure TCustomPathLabel.DoDrawTextIntern(var Rect: TRect; Flags: Longint; S: string);
  414. var
  415. i: Integer;
  416. Width: Integer;
  417. WidthMask: Integer;
  418. WidthPath: Integer;
  419. HotTrackOffset: Integer;
  420. HotTrackBottom: Integer;
  421. Separator: string;
  422. Str: string;
  423. begin
  424. if (Flags and DT_CALCRECT <> 0) and ((S = '') or ShowAccelChar and
  425. (S[1] = '&') and (S[2] = #0)) then S := S + ' ';
  426. if not ShowAccelChar then Flags := Flags or DT_NOPREFIX;
  427. // have to apply DrawTextBiDiModeFlags if we ever deal with dibi
  428. Canvas.Font := Font;
  429. Width := (Rect.Right - Rect.Left);
  430. FDisplayPath := S;
  431. FDisplayMask := Mask;
  432. Separator := '';
  433. if FDisplayMask <> '' then
  434. begin
  435. if FUnixPath then
  436. begin
  437. if (Length(FDisplayPath) > 0) and (FDisplayPath[Length(FDisplayPath)] <> '/') then
  438. Separator := '/';
  439. end
  440. else
  441. begin
  442. if (Length(FDisplayPath) > 0) and (FDisplayPath[Length(FDisplayPath)] <> '\') then
  443. Separator := '\';
  444. end;
  445. FDisplayPath := FDisplayPath + Separator;
  446. S := S + Separator;
  447. WidthMask := Canvas.TextWidth(FDisplayMask);
  448. if WidthMask > Width div 3 then
  449. WidthPath := Width - (Width div 3)
  450. else
  451. WidthPath := Width - WidthMask;
  452. end
  453. else
  454. begin
  455. WidthMask := 0;
  456. WidthPath := Width;
  457. end;
  458. if FUnixPath then
  459. for i := 1 to Length(FDisplayPath) do
  460. begin
  461. case FDisplayPath[i] of
  462. '/': FDisplayPath[i] := '\';
  463. '\': FDisplayPath[i] := '/';
  464. end;
  465. end;
  466. FDisplayPath := MinimizeName(FDisplayPath, Canvas, WidthPath);
  467. if FUnixPath then
  468. for i := 1 to Length(FDisplayPath) do
  469. begin
  470. case FDisplayPath[i] of
  471. '\': FDisplayPath[i] := '/';
  472. '/': FDisplayPath[i] := '\';
  473. end;
  474. end;
  475. WidthPath := Canvas.TextWidth(FDisplayPath);
  476. if FDisplayMask <> '' then
  477. begin
  478. if WidthMask > Width - WidthPath then
  479. begin
  480. FDisplayMask := FDisplayMask + '...';
  481. repeat
  482. Delete(FDisplayMask, Length(FDisplayMask) - 3, 1);
  483. WidthMask := Canvas.TextWidth(FDisplayMask);
  484. until (WidthMask <= Width - WidthPath) or (Length(FDisplayMask) = 3);
  485. end;
  486. end;
  487. ShowHint :=
  488. (FDisplayPath <> S) or
  489. (FDisplayMask <> Mask) or
  490. (WidthPath + WidthMask > Width);
  491. if not ShowHint then Hint := ''
  492. else Hint := S + Mask;
  493. Str := FDisplayPath + FDisplayMask;
  494. if not FIsEnabled then
  495. begin
  496. Canvas.Font.Color := clBtnShadow;
  497. DrawText(Canvas.Handle, PChar(Str), Length(Str), Rect, Flags);
  498. end
  499. else
  500. begin
  501. FDisplayHotTrack := HotTrackPath(FDisplayPath);
  502. if FDisplayHotTrack <> '' then
  503. begin
  504. if TrackingActive then
  505. begin
  506. Canvas.Font.Color := FColors[4 + Integer(FIsActive)]
  507. end
  508. else
  509. begin
  510. // We do not have a path label with hot-track and not tracking-active,
  511. // so this is untested branch
  512. Assert(False);
  513. // As if it were active
  514. Canvas.Font.Color := FColors[2 + 1];
  515. end;
  516. DrawText(Canvas.Handle, PChar(FDisplayHotTrack), Length(FDisplayHotTrack), Rect, Flags);
  517. HotTrackOffset := Canvas.TextWidth(FDisplayHotTrack);
  518. Inc(Rect.Left, HotTrackOffset);
  519. Delete(Str, 1, Length(FDisplayHotTrack));
  520. HotTrackBottom := Rect.Bottom;
  521. end
  522. else
  523. begin
  524. HotTrackOffset := 0;
  525. HotTrackBottom := 0;
  526. end;
  527. if TrackingActive then
  528. Canvas.Font.Color := FColors[2 + Integer(FIsActive)]
  529. else
  530. Canvas.Font.Color := clWindowText;
  531. DrawText(Canvas.Handle, PChar(Str), Length(Str), Rect, Flags);
  532. Dec(Rect.Left, HotTrackOffset);
  533. Rect.Bottom := Max(Rect.Bottom, HotTrackBottom);
  534. end;
  535. end;
  536. procedure TCustomPathLabel.DoDrawText(var Rect: TRect; Flags: Longint);
  537. begin
  538. DoDrawTextIntern(Rect, Flags, Caption);
  539. end;
  540. function TCustomPathLabel.HotTrackPath(Path: string): string;
  541. var
  542. P: TPoint;
  543. DelimPos: Integer;
  544. Delim: Char;
  545. Len: Integer;
  546. begin
  547. Result := '';
  548. if UseHotTrack and FMouseInView and (Path <> '') then
  549. begin
  550. P := ScreenToClient(Mouse.CursorPos);
  551. Len := P.X - FIndentHorizontal;
  552. if (Len >= 0) and (Len < Canvas.TextWidth(Path)) then
  553. begin
  554. if FUnixPath then Delim := '/'
  555. else Delim := '\';
  556. Result := '';
  557. repeat
  558. Assert(Path <> '');
  559. DelimPos := Pos(Delim, Path);
  560. if DelimPos > 0 then
  561. begin
  562. Result := Result + Copy(Path, 1, DelimPos);
  563. Delete(Path, 1, DelimPos);
  564. end
  565. else
  566. begin
  567. Result := Result + Path;
  568. Path := '';
  569. end;
  570. until (Canvas.TextWidth(Result) >= Len) or (Path = '');
  571. end;
  572. end;
  573. end;
  574. function TCustomPathLabel.GetColors(Index: Integer): TColor;
  575. begin
  576. Assert(Index in [0..5]);
  577. Result := FColors[Index];
  578. end; { GetColors }
  579. function TCustomPathLabel.UseRightToLeftAlignment: Boolean;
  580. begin
  581. // Not sure how to properly deal with RTL atm.
  582. // See also a comment on DrawTextBiDiModeFlags in DoDrawTextIntern
  583. Result := False;
  584. end;
  585. procedure TCustomPathLabel.Paint;
  586. const
  587. Alignments: array[TAlignment] of Word = (DT_LEFT, DT_RIGHT, DT_CENTER);
  588. WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  589. var
  590. Rect, CalcRect: TRect;
  591. DrawStyle: Longint;
  592. begin
  593. with Canvas do
  594. begin
  595. if not Transparent then
  596. begin
  597. Brush.Color := Self.Color;
  598. Brush.Style := bsSolid;
  599. FillRect(ClientRect);
  600. end;
  601. Brush.Style := bsClear;
  602. Rect := ClientRect;
  603. // DoDrawText takes care of BiDi alignments
  604. DrawStyle := DT_EXPANDTABS or WordWraps[WordWrap] or Alignments[Alignment];
  605. // MP
  606. Rect.Left := Rect.Left + FIndentHorizontal;
  607. Rect.Right := Rect.Right - FIndentHorizontal;
  608. Rect.Top := Rect.Top + FIndentVertical;
  609. Rect.Bottom := Rect.Bottom - FIndentVertical;
  610. // Calculate vertical layout
  611. if Layout <> tlTop then
  612. begin
  613. CalcRect := Rect;
  614. DoDrawText(CalcRect, DrawStyle or DT_CALCRECT);
  615. if Layout = tlBottom then OffsetRect(Rect, 0, Height - CalcRect.Bottom)
  616. else OffsetRect(Rect, 0, (Height - CalcRect.Bottom) div 2);
  617. end;
  618. DoDrawText(Rect, DrawStyle);
  619. end;
  620. end;
  621. procedure TCustomPathLabel.AdjustBounds;
  622. const
  623. WordWraps: array[Boolean] of Word = (0, DT_WORDBREAK);
  624. var
  625. DC: HDC;
  626. X: Integer;
  627. Rect: TRect;
  628. AAlignment: TAlignment;
  629. AWidth: Integer;
  630. AHeight: Integer;
  631. S: string;
  632. begin
  633. if not (csReading in ComponentState) and
  634. (AutoSize or AutoSizeVertical) then
  635. begin
  636. Rect := ClientRect;
  637. DC := GetDC(0);
  638. Canvas.Handle := DC;
  639. S := Caption;
  640. if S = '' then S := 'SomeTextForSizing';
  641. DoDrawTextIntern(Rect, (DT_EXPANDTABS or DT_CALCRECT) or WordWraps[WordWrap], S);
  642. Canvas.Handle := 0;
  643. ReleaseDC(0, DC);
  644. X := Left;
  645. AAlignment := Alignment;
  646. if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment);
  647. if AAlignment = taRightJustify then Inc(X, Width - 2*FIndentHorizontal + Rect.Right);
  648. if AutoSize then AWidth := 2*FIndentHorizontal + Rect.Right
  649. else AWidth := Width;
  650. if AutoSize or AutoSizeVertical then AHeight := 2*FIndentVertical + Rect.Bottom
  651. else AHeight := Height;
  652. SetBounds(X, Top, AWidth, AHeight);
  653. end;
  654. end;
  655. function TCustomPathLabel.IsActive: Boolean;
  656. begin
  657. if csDestroying in ComponentState then Result := False
  658. else
  659. begin
  660. Result := Assigned(FocusControl) and FocusControl.Focused;
  661. if Assigned(OnGetStatus) then
  662. OnGetStatus(Self, Result);
  663. end;
  664. end;
  665. function TCustomPathLabel.TrackingActive: Boolean;
  666. begin
  667. Result := Assigned(FocusControl) or Assigned(OnGetStatus);
  668. end;
  669. procedure TCustomPathLabel.UpdateStatus;
  670. var
  671. NewIsActive: Boolean;
  672. NewIsEnabled: Boolean;
  673. NewColor: TColor;
  674. begin
  675. if TrackingActive then
  676. begin
  677. NewIsActive := IsActive;
  678. NewIsEnabled :=
  679. Enabled and
  680. ((not Assigned(FocusControl)) or FocusControl.Enabled);
  681. NewColor := FColors[Integer(NewIsActive)];
  682. if (NewIsActive <> FIsActive) or
  683. (NewIsEnabled <> FIsEnabled) or
  684. (NewColor <> Color) then
  685. begin
  686. FIsActive := NewIsActive;
  687. FIsEnabled := NewIsEnabled;
  688. Color := NewColor;
  689. Invalidate;
  690. end;
  691. end
  692. else
  693. begin
  694. Color := clBtnFace;
  695. end;
  696. end; { UpdateStatus }
  697. procedure TCustomPathLabel.Notification(AComponent: TComponent;
  698. Operation: TOperation);
  699. var
  700. NeedUpdate: Boolean;
  701. begin
  702. NeedUpdate :=
  703. (Operation = opRemove) and (AComponent = FocusControl);
  704. inherited;
  705. if NeedUpdate then UpdateStatus;
  706. end; { Notification }
  707. function TCustomPathLabel.UseHotTrack: Boolean;
  708. begin
  709. Result := HotTrack and FIsEnabled;
  710. end;
  711. procedure TCustomPathLabel.MouseMove(Shift: TShiftState; X: Integer; Y: Integer);
  712. begin
  713. inherited;
  714. if FMouseInView and UseHotTrack and (FDisplayHotTrack <> HotTrackPath(FDisplayPath)) then
  715. begin
  716. Invalidate;
  717. end;
  718. end;
  719. procedure TCustomPathLabel.DoPathClick(Path: string);
  720. begin
  721. if Assigned(OnPathClick) then
  722. OnPathClick(Self, Path);
  723. end;
  724. procedure TCustomPathLabel.DblClick;
  725. begin
  726. if FIsEnabled then
  727. begin
  728. inherited;
  729. end;
  730. end;
  731. procedure TCustomPathLabel.DoContextPopup(MousePos: TPoint; var Handled: Boolean);
  732. begin
  733. if FIsEnabled then
  734. begin
  735. inherited;
  736. end
  737. else
  738. begin
  739. Handled := True;
  740. end;
  741. end;
  742. procedure TCustomPathLabel.CMMouseEnter(var Message: TMessage);
  743. begin
  744. inherited;
  745. FMouseInView := True;
  746. end;
  747. procedure TCustomPathLabel.CMMouseLeave(var Message: TMessage);
  748. begin
  749. FMouseInView := False;
  750. Invalidate;
  751. inherited;
  752. end;
  753. end.