BreadcrumbBar.pas

Filename: C:\Users\Andreas Rejbrand\Documents\BreakcrumBar\BreadcrumbBar.pas

Time: 2011-06-04 13:32:16

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.