TBreadcrumbBar controlThe breadcrumb control is a VCL control used to navigate tree-like structures, such as a file system.
Style := bbsClassic
Style := bbsFlat
Style := bbsHeader
Style := bbsThemed
Style := bbsCommand
unit BreadcrumbBar; interface uses Windows, Messages, SysUtils, Graphics, Classes, Controls, Menus, StdCtrls, UxTheme; resourcestring SCopyText = 'Copy as text'; SEmptyDir = '(The folder is empty)'; SPathNotFoundCaption = 'Path not found'; SPathNotFoundText = 'The path "%s" was not found.'; type RectArray = array of TRect; IntegerArray = array of integer; StringArray = array of string; TOnEditorReturn = function(Sender: TObject; const Text: string): boolean of object; TOnGetBreadcrumbs = procedure(Sender: TObject; Breadcrumbs: TStrings) of object; TOnGetBreadcrumbList = procedure(Sender: TObject; BreadcrumbIndex: integer; List: TStrings) of object; TOnBreadcrumbClick = procedure(Sender: TObject; BreadcrumbIndex: integer) of object; TOnBreadcrumbListItemClick = procedure(Sender: TObject; BreadcrumbIndex, ListIndex: integer) of object; TOnBreadcrumbBarGetText = procedure(Sender: TObject; var Text: string) of object; TBreadcrumbBarStyle = (bbsThemed, bbsCommand, bbsHeader, bbsClassic, bbsFlat); TPopupMenu = class(Menus.TPopupMenu) private FOnClose: TNotifyEvent; public procedure Popup(X: Integer; Y: Integer); override; procedure PopupAtPoint(Point: TPoint); property OnClose: TNotifyEvent read FOnClose write FOnClose; end; TCustomBreadcrumbBar = class(TCustomControl) type TRectState = (rsNormal, rsHover, rsDown); TRectStateArray = array of TRectState; const ARROW_SIZE = 8; ARROW_BOX_SIZE = 16; SEP_PADDING = 16; INDENT = 3; VERT_PADDING = 3; private { Private declarations } FOnGetBreadcrumbs: TOnGetBreadcrumbs; FOnGetBreadcrumbList: TOnGetBreadcrumbList; FOnBreadcrumbClick: TOnBreadcrumbClick; FOnBreadcrumbListItemClick: TOnBreadcrumbListItemClick; FOnEditorReturn: TOnEditorReturn; FCurrentItems: TStrings; FCurrentListItems: TStrings; FBreadcrumbRects: RectArray; FBreadcrumbArrowRects: RectArray; FBreadcrumbStates: TRectStateArray; FArrowStates: TRectStateArray; FOldBreadcrumbStates: TRectStateArray; FOldArrowStates: TRectStateArray; FImages: TImageList; FPopupMenu: TPopupMenu; FPopupMenuOpen: Boolean; FEditable: boolean; FEdit: TEdit; FOnBreadcrumbBarGetText: TOnBreadcrumbBarGetText; FCrumbDown: Integer; FBarPopup: TPopupMenu; FStyle: TBreadcrumbBarStyle; procedure DrawArrow(ArrowRect: TRect); procedure ResetRectStates; function PointInRect(X, Y: integer; const Rect: TRect): boolean; inline; function GetMouseState: TRectState; procedure HasRectStatesChanged; procedure ShowArrowPopup(BreadcrumbIndex: integer); procedure ArrowPopupClose(Sender: TObject); function IsEditMode: boolean; procedure GoEditing; procedure EditKeyPress(Sender: TObject; var Key: char); procedure HideEditor; procedure SetStates(X, Y: Integer); function MouseButtonDown: boolean; inline; function GetCrumbDown: integer; function GetCrumbHover: integer; procedure CopyTextClick(Sender: TObject); function MakeDefaultText: string; procedure EditExit(Sender: TObject); procedure ArrowItemClick(Sender: TObject); procedure SetStyle(const Value: TBreadcrumbBarStyle); protected procedure Paint; override; procedure Loaded; override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure WndProc(var Message: TMessage); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; property OnGetBreadcrumbs: TOnGetBreadcrumbs read FOnGetBreadcrumbs write FOnGetBreadcrumbs; property OnGetBreadcrumbList: TOnGetBreadcrumbList read FOnGetBreadcrumbList write FOnGetBreadcrumbList; property OnBreadcrumbClick: TOnBreadcrumbClick read FOnBreadcrumbClick write FOnBreadcrumbClick; property OnBreadcrumbListItemClick: TOnBreadcrumbListItemClick read FOnBreadcrumbListItemClick write FOnBreadcrumbListItemClick; property OnBreadcrumbBarGetText: TOnBreadcrumbBarGetText read FOnBreadcrumbBarGetText write FOnBreadcrumbBarGetText; property OnEditorReturn: TOnEditorReturn read FOnEditorReturn write FOnEditorReturn; property Editable: boolean read FEditable write FEditable default true; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure UpdateBreadcrumbs; property EditMode: boolean read IsEditMode; function GetBreadcrumb(Index: integer): string; function GetBreadcrumbListItem(Index: integer): string; property Images: TImageList read FImages; property Style: TBreadcrumbBarStyle read FStyle write SetStyle default bbsThemed; property DoubleBuffered; end; TBreadcrumbBar = class(TCustomBreadcrumbBar) published property DoubleBuffered; property Style; property Editable; property OnGetBreadcrumbs; property OnGetBreadcrumbList; property OnBreadcrumbClick; property OnBreadcrumbListItemClick; property OnBreadcrumbBarGetText; end; TFileExecEvent = procedure(const FileName: TFileName) of object; TURLExecEvent = procedure(const URL: string) of object; TDirBreadcrumbBar = class(TCustomBreadcrumbBar) private FDirectory: string; FRoot: string; FBreadcrumbs: StringArray; FShowHiddenDirs: boolean; FOnFileExec: TFileExecEvent; FOnURLExec: TURLExecEvent; FOnChange: TNotifyEvent; procedure GetBreadcrumbs(Sender: TObject; Breadcrumbs: TStrings); procedure GetBreadcrumbList(Sender: TObject; BreadcrumbIndex: integer; List: TStrings); procedure BreadcrumbClick(Sender: TObject; BreadcrumbIndex: integer); procedure BreadcrumbListClick(Sender: TObject; BreadcrumbIndex, ListIndex: integer); procedure BreadcrumbBarGetText(Sender: TObject; var Text: string); procedure SetDirectory(const Value: string); procedure SetRoot(const Value: string); function SplitPath(const APath: string): StringArray; function GetDirUpTo(Level: integer): string; function EditorReturn(Sender: TObject; const Text: string): boolean; function IsURL(const S: string): boolean; public constructor Create(AOwner: TComponent); override; published property DoubleBuffered; property Directory: string read FDirectory write SetDirectory; property Root: string read FRoot write SetRoot; property ShowHiddenDirs: boolean read FShowHiddenDirs write FShowHiddenDirs default false; property Style; property Editable; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnFileExec: TFileExecEvent read FOnFileExec write FOnFileExec; property OnURLExec: TURLExecEvent read FOnURLExec write FOnURLExec; end; procedure Register; implementation uses Math, ShellAPI, CommCtrl, ImgList, Dialogs, Clipbrd, ShLwApi, Forms; procedure Register; begin RegisterComponents('Rejbrand 2009', [TBreadcrumbBar, TDirBreadcrumbBar]); end; { TBreadcrumbBar } constructor TCustomBreadcrumbBar.Create(AOwner: TComponent); var MenuItem: TMenuItem; begin inherited; FCurrentItems := TStringList.Create; FCurrentListItems := TStringList.Create; FImages := TImageList.Create(Self); FImages.Width := 16; FImages.Height := 16; FPopupMenu := TPopupMenu.Create(Self); FPopupMenu.Images := FImages; FPopupMenu.OnClose := ArrowPopupClose; FPopupMenuOpen := false; FStyle := bbsThemed; Width := 512; Height := 32; FEdit := TEdit.Create(Self); FEdit.Visible := false; FEdit.Parent := Self; FEdit.Align := alClient; FEdit.OnKeyPress := EditKeyPress; FEdit.OnExit := EditExit; FEditable := true; FBarPopup := TPopupMenu.Create(Self); MenuItem := TMenuItem.Create(FBarPopup); MenuItem.Caption := SCopyText; MenuItem.OnClick := CopyTextClick; FBarPopup.Items.Add(MenuItem); FCrumbDown := -1; end; destructor TCustomBreadcrumbBar.Destroy; begin FBarPopup.Free; FPopupMenu.Free; FImages.Free; FCurrentListItems.Free; FCurrentItems.Free; inherited; end; procedure TCustomBreadcrumbBar.Loaded; begin inherited; UpdateBreadcrumbs; end; procedure TCustomBreadcrumbBar.EditExit(Sender: TObject); begin HideEditor; end; procedure TCustomBreadcrumbBar.CopyTextClick(Sender: TObject); var S: string; begin S := MakeDefaultText; if Assigned(FOnBreadcrumbBarGetText) then FOnBreadcrumbBarGetText(Self, S); Clipboard.AsText := S; end; procedure TCustomBreadcrumbBar.HideEditor; begin FEdit.Hide; ResetRectStates; Invalidate; end; procedure TCustomBreadcrumbBar.EditKeyPress(Sender: TObject; var Key: char); begin case ord(Key) of VK_ESCAPE: begin HideEditor; Key := #0; end; VK_RETURN: begin if Assigned(FOnEditorReturn) then if not FOnEditorReturn(Self, FEdit.Text) then Exit; HideEditor; Key := #0; end; end; end; procedure TCustomBreadcrumbBar.ArrowPopupClose(Sender: TObject); begin FPopupMenuOpen := false; ResetRectStates; HasRectStatesChanged; end; procedure TCustomBreadcrumbBar.ShowArrowPopup(BreadcrumbIndex: integer); var i: Integer; AMenuItem: TMenuItem; pnt: TPoint; begin FPopupMenu.Items.Clear; for i := 0 to FCurrentListItems.Count - 1 do begin AMenuItem := TMenuItem.Create(FPopupMenu); AMenuItem.Caption := FCurrentListItems[i]; AMenuItem.Tag := i or (BreadcrumbIndex shl 16); AMenuItem.ImageIndex := integer(FCurrentListItems.Objects[i]); AMenuItem.OnClick := ArrowItemClick; FPopupMenu.Items.Add(AMenuItem); end; if FCurrentListItems.Count = 0 then begin AMenuItem := TMenuItem.Create(FPopupMenu); AMenuItem.Caption := SEmptyDir; AMenuItem.Enabled := false; FPopupMenu.Items.Add(AMenuItem); end; pnt.X := FBreadcrumbArrowRects[BreadcrumbIndex].Left; pnt.Y := FBreadcrumbArrowRects[BreadcrumbIndex].Bottom; pnt := ClientToScreen(pnt); Paint; FPopupMenuOpen := true; FPopupMenu.Popup(pnt.X, pnt.Y); end; procedure TCustomBreadcrumbBar.ArrowItemClick(Sender: TObject); begin if Assigned(FOnBreadcrumbListItemClick) then if Sender is TMenuItem then with Sender as TMenuItem do FOnBreadcrumbListItemClick(Self, Tag shr 16, Word(Tag)); end; function TCustomBreadcrumbBar.MakeDefaultText: string; var i: integer; begin for i := 0 to FCurrentItems.Count - 1 do if i < FCurrentItems.Count - 1 then result := result + FCurrentItems[i] + '\' else result := result + FCurrentItems[i]; end; procedure TCustomBreadcrumbBar.GoEditing; var S: string; begin S := MakeDefaultText; if Assigned(FOnBreadcrumbBarGetText) then FOnBreadcrumbBarGetText(Self, S); FEdit.Text := S; FEdit.Show; if FEdit.CanFocus then FEdit.SetFocus; end; procedure TCustomBreadcrumbBar.SetStates(X, Y: Integer); var i: integer; begin for i := 0 to FCurrentItems.Count - 1 do if PointInRect(X, Y, FBreadcrumbRects[i]) then begin FBreadcrumbStates[i] := GetMouseState; break; end else if PointInRect(X, Y, FBreadcrumbArrowRects[i]) then begin FArrowStates[i] := GetMouseState; break; end; end; procedure TCustomBreadcrumbBar.SetStyle(const Value: TBreadcrumbBarStyle); begin if FStyle <> Value then begin FStyle := Value; Invalidate; end; end; procedure TCustomBreadcrumbBar.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); var i: Integer; begin inherited; ResetRectStates; SetStates(X, Y); HasRectStatesChanged; for i := 0 to FCurrentItems.Count - 1 do if FArrowStates[i] = rsDown then begin if Assigned(FOnGetBreadcrumbList) then begin FCurrentListItems.Clear; Screen.Cursor := crHourGlass; try FOnGetBreadcrumbList(Self, i, FCurrentListItems); ShowArrowPopup(i); finally Screen.Cursor := crDefault; end; end; break; end else if FBreadcrumbStates[i] = rsDown then begin FCrumbDown := i; break; end; end; procedure TCustomBreadcrumbBar.MouseMove(Shift: TShiftState; X, Y: Integer); begin inherited; if MouseButtonDown then Exit; ResetRectStates; SetStates(X, Y); HasRectStatesChanged; end; procedure TCustomBreadcrumbBar.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; ResetRectStates; SetStates(X, Y); HasRectStatesChanged; case Button of mbLeft: if FEditable and ((FCurrentItems.Count = 0) or (X > FBreadcrumbArrowRects[high(FBreadcrumbArrowRects)].Right)) then GoEditing else if (FCrumbDown >= 0) and (GetCrumbHover = FCrumbDown) then if Assigned(FOnBreadcrumbClick) then FOnBreadcrumbClick(Self, FCrumbDown); mbRight: FBarPopup.PopupAtPoint(ClientToScreen(Point(X, Y))); mbMiddle: ; end; end; function TCustomBreadcrumbBar.GetBreadcrumb(Index: integer): string; begin result := FCurrentItems[Index]; end; function TCustomBreadcrumbBar.GetBreadcrumbListItem(Index: integer): string; begin result := FCurrentListItems[Index]; end; function TCustomBreadcrumbBar.GetCrumbDown: integer; var i: Integer; begin result := -1; for i := 0 to FCurrentItems.Count - 1 do if FBreadcrumbStates[i] = rsDown then Exit(i); end; function TCustomBreadcrumbBar.GetCrumbHover: integer; var i: Integer; begin result := -1; for i := 0 to FCurrentItems.Count - 1 do if FBreadcrumbStates[i] <> rsNormal then Exit(i); end; procedure TCustomBreadcrumbBar.DrawArrow(ArrowRect: TRect); var arr: array[0..2] of TPoint; xleft, xright, ytop, ybottom, ymiddle: integer; begin Canvas.Brush.Style := bsSolid; Canvas.Brush.Color := clBlack; Canvas.Pen.Style := psSolid; Canvas.Pen.Mode := pmCopy; xleft := ArrowRect.Left + (ArrowRect.Right - ArrowRect.Left - ARROW_SIZE) div 2; xright := xleft + ARROW_SIZE; ytop := (Height - ARROW_SIZE) div 2; ybottom := ytop + ARROW_SIZE; ymiddle := ytop + ARROW_SIZE div 2; arr[0] := Point(xleft, ytop); arr[1] := Point(xleft, ybottom); arr[2] := Point(xright, ymiddle); Canvas.Polygon(arr); end; function TCustomBreadcrumbBar.MouseButtonDown: boolean; begin MouseButtonDown := GetKeyState(VK_LBUTTON) and $8000 <> 0; end; function TCustomBreadcrumbBar.GetMouseState: TRectState; begin if MouseButtonDown then result := rsDown else result := rsHover; end; procedure TCustomBreadcrumbBar.Paint; var i: Integer; S: string; r: TRect; AStyle: TBreadcrumbBarStyle; theme: HTHEME; MaxWidth: integer; var EDGE_FLAGS: integer; A_VERT_PADDING: integer; A_INDENT: integer; const RectConst: array[TRectState] of integer = (BDR_RAISED, BDR_RAISED, BDR_SUNKEN); begin inherited; if EditMode then Exit; MaxWidth := floor(Width / FCurrentItems.Count) - ARROW_BOX_SIZE - SEP_PADDING; AStyle := FStyle; A_VERT_PADDING := VERT_PADDING; A_INDENT := INDENT; if (AStyle = bbsThemed) and not UseThemes then AStyle := bbsClassic; if ((AStyle = bbsCommand) or (AStyle = bbsHeader)) and not UseThemes then AStyle := bbsFlat; if AStyle = bbsHeader then begin A_INDENT := 0; A_VERT_PADDING := 0; end; if AStyle = bbsFlat then EDGE_FLAGS := BF_FLAT else EDGE_FLAGS := 0; FillRect(Canvas.Handle, ClientRect, GetStockObject(WHITE_BRUSH)); r := ClientRect; case AStyle of bbsThemed: ; bbsCommand: ; bbsHeader: ; bbsClassic, bbsFlat: begin DrawEdge(Canvas.Handle, r, EDGE_SUNKEN, BF_RECT or EDGE_FLAGS); Canvas.Pen.Color := clBlack; Canvas.Pen.Style := psSolid; end; end; for i := 0 to FCurrentItems.Count - 1 do begin if i = 0 then FBreadcrumbRects[i].Left := A_INDENT else FBreadcrumbRects[i].Left := FBreadcrumbArrowRects[i - 1].Right; FBreadcrumbRects[i].Top := A_VERT_PADDING; S := FCurrentItems[i]; DrawText(Canvas.Handle, PChar(S), length(S), FBreadcrumbRects[i], DT_SINGLELINE or DT_LEFT or DT_VCENTER or DT_CALCRECT); FBreadcrumbRects[i].Right := Min(FBreadcrumbRects[i].Right, FBreadcrumbRects[i].Left + MaxWidth); FBreadcrumbRects[i].Bottom := Height - A_VERT_PADDING; inc(FBreadcrumbRects[i].Right, SEP_PADDING); case AStyle of bbsThemed: begin theme := OpenThemeData(Handle, 'BUTTON'); if theme <> 0 then try case FBreadcrumbStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_NORMAL, FBreadcrumbRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_HOT, FBreadcrumbRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_PRESSED, FBreadcrumbRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsCommand: begin theme := OpenThemeData(Handle, 'BUTTON'); if theme <> 0 then try case FBreadcrumbStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_NORMAL, FBreadcrumbRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_HOT, FBreadcrumbRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_PRESSED, FBreadcrumbRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsHeader: begin theme := OpenThemeData(Handle, 'HEADER'); if theme <> 0 then try case FBreadcrumbStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_NORMAL, FBreadcrumbRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_HOT, FBreadcrumbRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_PRESSED, FBreadcrumbRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsClassic, bbsFlat: begin if FBreadcrumbStates[i] <> rsNormal then Canvas.Brush.Color := clHighlight else Canvas.Brush.Color := clBtnFace; Canvas.Brush.Style := bsSolid; FillRect(Canvas.Handle, FBreadcrumbRects[i], Canvas.Brush.Handle); DrawEdge(Canvas.Handle, FBreadcrumbRects[i], RectConst[FBreadcrumbStates[i]], BF_RECT or EDGE_FLAGS); end; end; Canvas.Brush.Style := bsClear; DrawText(Canvas.Handle, PChar(S), length(S), FBreadcrumbRects[i], DT_SINGLELINE or DT_CENTER or DT_VCENTER or DT_END_ELLIPSIS); FBreadcrumbArrowRects[i].Left := FBreadcrumbRects[i].Right; FBreadcrumbArrowRects[i].Top := A_VERT_PADDING; FBreadcrumbArrowRects[i].Bottom := Height - A_VERT_PADDING; FBreadcrumbArrowRects[i].Right := FBreadcrumbArrowRects[i].Left + ARROW_BOX_SIZE; case AStyle of bbsThemed: begin theme := OpenThemeData(Handle, 'BUTTON'); if theme <> 0 then try case FArrowStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_NORMAL, FBreadcrumbArrowRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_HOT, FBreadcrumbArrowRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, BP_PUSHBUTTON, PBS_PRESSED, FBreadcrumbArrowRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsCommand: begin theme := OpenThemeData(Handle, 'BUTTON'); if theme <> 0 then try case FArrowStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_NORMAL, FBreadcrumbArrowRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_HOT, FBreadcrumbArrowRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, BP_COMMANDLINK, CMDLS_PRESSED, FBreadcrumbArrowRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsHeader: begin theme := OpenThemeData(Handle, 'HEADER'); if theme <> 0 then try case FArrowStates[i] of rsNormal: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_NORMAL, FBreadcrumbArrowRects[i], nil); rsHover: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_HOT, FBreadcrumbArrowRects[i], nil); rsDown: DrawThemeBackground(theme, Canvas.Handle, HP_HEADERITEM, HIS_PRESSED, FBreadcrumbArrowRects[i], nil); end; finally CloseThemeData(theme); end; end; bbsClassic, bbsFlat: begin if FArrowStates[i] <> rsNormal then Canvas.Brush.Color := clHighlight else Canvas.Brush.Color := clBtnFace; Canvas.Brush.Style := bsSolid; FillRect(Canvas.Handle, FBreadcrumbArrowRects[i], Canvas.Brush.Handle); DrawEdge(Canvas.Handle, FBreadcrumbArrowRects[i], RectConst[FArrowStates[i]], BF_RECT or EDGE_FLAGS); end; end; DrawArrow(FBreadcrumbArrowRects[i]); end; end; function TCustomBreadcrumbBar.PointInRect(X, Y: integer; const Rect: TRect): boolean; begin result := InRange(X, Rect.Left, Rect.Right) and InRange(Y, Rect.Top, Rect.Bottom); end; procedure TCustomBreadcrumbBar.ResetRectStates; var i: Integer; begin if FPopupMenuOpen then Exit; FOldBreadcrumbStates := Copy(FBreadcrumbStates); FOldArrowStates := Copy(FArrowStates); for i := 0 to FCurrentItems.Count - 1 do begin FBreadcrumbStates[i] := rsNormal; FArrowStates[i] := rsNormal; end; end; procedure TCustomBreadcrumbBar.HasRectStatesChanged; var i: Integer; begin for i := 0 to FCurrentItems.Count - 1 do begin if (FBreadcrumbStates[i] <> FOldBreadcrumbStates[i]) then InvalidateRect(Handle, FBreadcrumbRects[i], true); if (FArrowStates[i] <> FOldArrowStates[i]) then InvalidateRect(Handle, FBreadcrumbArrowRects[i], true); end; end; function TCustomBreadcrumbBar.IsEditMode: boolean; begin IsEditMode := FEdit.Visible; end; procedure TCustomBreadcrumbBar.UpdateBreadcrumbs; begin if (csDesigning in ComponentState) then Exit; if not (Assigned(FOnGetBreadcrumbs)) then raise EInvalidOperation.Create('Event FOnGetBreadcrumbs not assigned.'); FCurrentItems.Clear; FOnGetBreadcrumbs(Self, FCurrentItems); SetLength(FBreadcrumbRects, FCurrentItems.Count); SetLength(FBreadcrumbArrowRects, FCurrentItems.Count); SetLength(FBreadcrumbStates, FCurrentItems.Count); SetLength(FArrowStates, FCurrentItems.Count); Invalidate; end; procedure TCustomBreadcrumbBar.WndProc(var Message: TMessage); begin inherited; case Message.Msg of WM_MOUSELEAVE: begin ResetRectStates; HasRectStatesChanged; end; end; end; { TPopupMenu } procedure TPopupMenu.Popup(X, Y: Integer); begin inherited; if Assigned(FOnClose) then FOnClose(Self); end; procedure TPopupMenu.PopupAtPoint(Point: TPoint); begin with Point do Popup(X, Y); end; { TDirBreadcrumbBar } constructor TDirBreadcrumbBar.Create(AOwner: TComponent); begin inherited; OnGetBreadcrumbs := GetBreadcrumbs; OnGetBreadcrumbList := GetBreadcrumbList; OnBreadcrumbClick := BreadcrumbClick; OnBreadcrumbListItemClick := BreadcrumbListClick; OnBreadcrumbBarGetText := BreadcrumbBarGetText; OnEditorReturn := EditorReturn; FShowHiddenDirs := false; end; function TDirBreadcrumbBar.SplitPath(const APath: string): StringArray; var SepPos: IntegerArray; i: Integer; begin SetLength(SepPos, 1); SepPos[0] := 0; for i := 1 to length(APath) do if APath[i] = '\' then begin SetLength(SepPos, length(SepPos) + 1); // I know. But paths aren't generally that long. SepPos[high(SepPos)] := i; end; SetLength(SepPos, length(SepPos) + 1); SepPos[high(SepPos)] := length(APath) + 1; SetLength(result, high(SepPos)); for i := 0 to high(SepPos) - 1 do result[i] := Copy(APath, SepPos[i] + 1, SepPos[i+1] - SepPos[i] - 1); end; function TDirBreadcrumbBar.IsURL(const S: string): boolean; const Protocols: array[0..4] of string = ('http://', 'https://', 'ftp://', 'mailto:', 'www'); var i: Integer; begin result := false; for i := 0 to high(Protocols) do if SameText(Copy(S, 1, length(Protocols[i])), Protocols[i]) then Exit(true); end; function TDirBreadcrumbBar.EditorReturn(Sender: TObject; const Text: string): boolean; var AText: string; begin AText := Text; if FileExists(Text) then if Assigned(FOnFileExec) then FOnFileExec(Text) else ShellExecute(0, nil, PChar(Text), nil, nil, SW_SHOWNORMAL) else if DirectoryExists(Text) then begin SetDirectory(Text); if Assigned(FOnChange) then FOnChange(Self); end else if IsURL(Text) then if Assigned(FOnURLExec) then FOnURLExec(Text) else ShellExecute(0, nil, PChar(Text), nil, nil, SW_SHOWNORMAL) else if (Win32MajorVersion >= 6) and UseThemes then with TTaskDialog.Create(Self) do try Caption := SPathNotFoundCaption; Title := SPathNotFoundCaption; Text := Format(SPathNotFoundText, [AText]); MainIcon := tdiInformation; CommonButtons := [tcbClose]; Execute; finally Free; end else MessageBox(Handle, PChar(Format(SPathNotFoundText, [Text])), PChar(SPathNotFoundCaption), MB_ICONINFORMATION or MB_OK); result := true; end; procedure TDirBreadcrumbBar.GetBreadcrumbs(Sender: TObject; Breadcrumbs: TStrings); var i: Integer; begin for i := 0 to high(FBreadcrumbs) do Breadcrumbs.Add(FBreadcrumbs[i]); end; function TDirBreadcrumbBar.GetDirUpTo(Level: integer): string; var i: Integer; begin result := FBreadcrumbs[0]; for i := 1 to Level do result := result + '\' + FBreadcrumbs[i]; end; procedure TDirBreadcrumbBar.SetDirectory(const Value: string); var AValue: string; begin SetLength(AValue, MAX_PATH); PathCanonicalize(PChar(AValue), PChar(Value)); SetLength(AValue, StrLen(PChar(AValue))); while (length(AValue) > 0) and (AValue[length(AValue)] = '\') do SetLength(AValue, length(AValue) - 1); if (not SameText(FDirectory, AValue)) and DirectoryExists(AValue) then begin FDirectory := AValue; FBreadcrumbs := SplitPath(FDirectory); UpdateBreadcrumbs; end; end; procedure TDirBreadcrumbBar.SetRoot(const Value: string); begin if (not SameText(FRoot, Value)) and DirectoryExists(Value) then begin FRoot := Value; UpdateBreadcrumbs; end; end; procedure TDirBreadcrumbBar.GetBreadcrumbList(Sender: TObject; BreadcrumbIndex: integer; List: TStrings); var SubPath: string; SR: TSearchRec; i: Integer; SFI: TSHFileInfo; h: HICON; IconHandles: IntegerArray; ActualLength: integer; function IconHandlesContains(h: integer): boolean; var j: Integer; begin result := false; for j := 0 to high(IconHandles) do if IconHandles[j] = h then Exit(true); end; function IconHandlesIndexOf(h: integer): integer; var j: Integer; begin result := 0; for j := 0 to high(IconHandles) do if IconHandles[j] = h then Exit(j); end; begin SubPath := GetDirUpTo(BreadcrumbIndex); if not DirectoryExists(SubPath) then Exit; SubPath := IncludeTrailingBackslash(SubPath); if FindFirst(SubPath + '*.*', faDirectory or faHidden, SR) = 0 then try repeat if (SR.Attr and faDirectory <> 0) and (SR.Name <> '..') and (SR.Name <> '.') and (FShowHiddenDirs or ((SR.Attr and faHidden = 0) and (Copy(SR.Name, 1, 1) <> '.'))) then begin if SHGetFileInfo(PChar(SubPath + SR.Name), 0, SFI, sizeof(SFI), SHGFI_ICON or SHGFI_SMALLICON) <> 0 then List.AddObject(SR.Name, TObject(SFI.hIcon)) else List.AddObject(SR.Name, nil); end; until FindNext(SR) <> 0; finally FindClose(SR); end; SetLength(IconHandles, List.Count); ActualLength := 0; for i := 0 to List.Count - 1 do if not IconHandlesContains(integer(List.Objects[i])) then begin IconHandles[ActualLength] := integer(List.Objects[i]); inc(ActualLength); end; SetLength(IconHandles, ActualLength); for i := 0 to List.Count - 1 do if Assigned(List.Objects[i]) then List.Objects[i] := TObject(IconHandlesIndexOf(integer(List.Objects[i]))); FImages.Clear; FImages.ColorDepth := cd32Bit; for i := 0 to high(IconHandles) do ImageList_AddIcon(FImages.Handle, IconHandles[i]); end; procedure TDirBreadcrumbBar.BreadcrumbClick(Sender: TObject; BreadcrumbIndex: integer); begin SetDirectory(GetDirUpTo(BreadcrumbIndex)); if Assigned(FOnChange) then FOnChange(Self); end; procedure TDirBreadcrumbBar.BreadcrumbListClick(Sender: TObject; BreadcrumbIndex, ListIndex: integer); begin SetDirectory(IncludeTrailingBackslash(GetDirUpTo(BreadcrumbIndex)) + GetBreadcrumbListItem(ListIndex)); if Assigned(FOnChange) then FOnChange(Self); end; procedure TDirBreadcrumbBar.BreadcrumbBarGetText(Sender: TObject; var Text: string); begin end; end.