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: stringof 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: stringof 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 = 0or
          (X > FBreadcrumbArrowRects[high(FBreadcrumbArrowRects)].Right)) then
          GoEditing
        
else
          if (FCrumbDown >= 0and (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..2of 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..4of 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(0nil, PChar(Text), nilnil, 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(0nil, PChar(Text), nilnil, SW_SHOWNORMAL)
  
else
    if (Win32MajorVersion >= 6and 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) > 0and (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 <> 0and (SR.Name <> '..'and
          (SR.Name <> '.'and (FShowHiddenDirs or ((SR.Attr and faHidden = 0)
          
and (Copy(SR.Name, 11) <> '.'))) 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.