pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity
Files
924efdfcb15f67b7571bccc7edc04db4ca0fe27e
lazarus-ccr/components/tvplanit/source/vpnavbar.pas
wp_xxyyzz 2d94675a6b tvplanit: Fix compilation error with fpc 3.1.1 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@4483 8e941d3f-bd1b-0410-a28a-d453659cc2b4
2016-01-31 11:40:49 +00:00

3081 lines
92 KiB
ObjectPascal
Raw Blame History

{*********************************************************}
{* VPNAVBAR.PAS 1.03 *}
{*********************************************************}
{* ***** BEGIN LICENSE BLOCK ***** *}
{* Version: MPL 1.1 *}
{* *}
{* The contents of this file are subject to the Mozilla Public License *}
{* Version 1.1 (the "License"); you may not use this file except in *}
{* compliance with the License. You may obtain a copy of the License at *}
{* http://www.mozilla.org/MPL/ *}
{* *}
{* Software distributed under the License is distributed on an "AS IS" basis, *}
{* WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License *}
{* for the specific language governing rights and limitations under the *}
{* License. *}
{* *}
{* The Original Code is TurboPower Visual PlanIt *}
{* *}
{* The Initial Developer of the Original Code is TurboPower Software *}
{* *}
{* Portions created by TurboPower Software Inc. are Copyright (C) 2002 *}
{* TurboPower Software Inc. All Rights Reserved. *}
{* *}
{* Contributor(s): *}
{* *}
{* ***** END LICENSE BLOCK ***** *}
{$I Vp.INC}
unit VpNavBar;
interface
uses
{$IFDEF LCL}
LMessages,LCLProc,LCLType,LCLIntf,
{$ELSE}
Windows,MMSystem,
{$ENDIF}
Messages,Controls, Graphics, Forms, Buttons, SysUtils,
StdCtrls, Classes, ExtCtrls, VpBase, VpConst, VpMisc, VpSR, Math;
type
{Forward Declaration}
TVpNavFolder = class;
TVpCustomNavBar = class;
TVpIconSize = (isLarge, isSmall);
TVpBackgroundMethod = (bmNone, bmNormal, bmStretch, bmTile);
TVpFolderDrawingStyle = (dsDefButton, dsEtchedButton, dsCoolTab,
dsStandardTab);
TVpFolderType = (ftDefault, ftContainer);
TVpFolderContainer = class(TPanel)
protected{Private}
FNavBar : TVpCustomNavBar;
FIndex : Integer;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
function GetChildOwner: TComponent; override;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Index: Integer Read FIndex;
property NavBar: TVpCustomNavBar read FNavBar;
end;
TVpNavBtnItem = class(TVpCollectionItem)
protected {private}
{property variables}
FFolder : TVpNavFolder;
FCaption : string;
FDescription : String;
FIconIndex : Integer;
FIconRect : TRect;
FLabelRect : TRect;
FTag : Integer;
{internal variables}
liDisplayName : string;
{property methods}
procedure SetCaption(const Value : string);
procedure SetIconIndex(Value : Integer);
public
constructor Create(Collection: TCollection); override;
destructor Destroy; override;
property Folder: TVpNavFolder read FFolder;
procedure Assign(Source: TPersistent); override;
property IconRect : TRect read FIconRect;
property LabelRect : TRect read FLabelRect;
published
property Caption : string
read FCaption write SetCaption;
property Description : string
read FDescription write FDescription;
property IconIndex : Integer
read FIconIndex write SetIconIndex;
property Name;
property Tag: Integer
read FTag write FTag;
end;
TVpNavFolder = class(TVpCollectionItem)
protected {private}
{property variables}
FNavBar : TVpCustomNavBar;
FCaption : string;
FEnabled : Boolean;
FIconSize : TVpIconSize;
FFolderType : TVpFolderType;
FContainerIndex : Integer;
FItems : TVpCollection;
{internal variables}
lfDisplayName : string;
lfRect : TRect;
FTag : Integer;
{property methods}
function GetItem(Index : Integer) : TVpNavBtnItem;
function GetItemCount : Integer;
procedure SetCaption(const Value : string);
procedure SetEnabled(Value : Boolean);
procedure SetFolderType(Value: TVpFolderType);
function CreateContainer: Integer;
procedure SetIconSize(Value : TVpIconSize);
procedure SetItem(Index : Integer; Value : TVpNavBtnItem);
procedure lfGetEditorCaption(var Caption : string);
procedure lfItemChange(Sender : TObject);
procedure DefineProperties(Filer: TFiler); override;
procedure ReadIndex(Reader: TReader);
procedure WriteIndex(Writer: TWriter);
public
constructor Create(Collection : TCollection); override;
destructor Destroy; override;
function GetContainer: TVpFolderContainer;
property Items[Index : Integer] : TVpNavBtnItem
read GetItem;
property ItemCount : Integer
read GetItemCount;
property ContainerIndex: Integer
read FContainerIndex write FContainerIndex;
published
property Caption : string
read FCaption write SetCaption;
property Enabled : Boolean
read FEnabled write SetEnabled;
property FolderType: TVpFolderType
read FFolderType write SetFolderType;
property ItemCollection : TVpCollection
read FItems write FItems;
property IconSize : TVpIconSize
read FIconSize write SetIconSize;
property Name;
property Tag: Integer
read FTag write FTag;
end;
TVpRenameEdit = class(TCustomMemo)
private
protected
procedure KeyPress(var Key: Char); override;
public
FolderIndex : Integer;
ItemIndex : Integer;
constructor Create(AOwner : TComponent); override;
end;
{NavBar Events}
TVpFolderClickEvent =
procedure(Sender : TObject; Button : TMouseButton; Shift : TShiftState;
Index : Integer) of object;
TVpItemClickEvent =
procedure(Sender : TObject; Button : TMouseButton; Shift : TShiftState;
Index : Integer) of object;
TVpFolderChangeEvent =
procedure(Sender : TObject; Index : Integer; var AllowChange : Boolean;
Dragging : Boolean) of object;
TVpFolderChangedEvent =
procedure(Sender : TObject; Index : Integer) of object;
TVpNABDragOverEvent =
procedure(Sender, Source: TObject; X, Y: Integer; State: TDragState;
var AcceptFolder, AcceptItem: Boolean) of object;
TVpNABDragDropEvent =
procedure(Sender, Source: TObject; X, Y: Integer;
FolderIndex, ItemIndex : Integer) of object;
TVpMouseOverItemEvent =
procedure(Sender : TObject; Item : TVpNavBtnItem) of object;
TVpCustomNavBar = class(TVpCustomControl)
protected {private}
{property variables}
FActiveFolder : Integer;
FActiveItem : Integer;
FAllowRearrange : Boolean;
FBackgroundColor : TColor;
FBackgroundImage : TBitmap;
FBackgroundMethod : TVpBackgroundMethod;
FBorderStyle : TBorderStyle;
FButtonHeight : Integer;
FContainers : TVpContainerList;
FDrawingStyle : TVpFolderDrawingStyle;
FFolders : TVpCollection;
FHotFolder : Integer;
FImages : TImageList;
FItemFont : TFont;
FItemSpacing : Word;
FPreviousFolder : Integer;
FPreviousItem : Integer;
FPlaySounds : Boolean;
FSelectedItem : Integer;
FSelectedItemFont : TFont;
FScrollDelta : Integer;
FShowButtons : Boolean;
FSoundAlias : string;
FLoadingFolder : Integer;
{event variables}
FOnArrange : TNotifyEvent;
FOnDragDrop : TVpNABDragDropEvent;
FOnDragOver : TVpNABDragOverEvent;
FOnFolderChange : TVpFolderChangeEvent;
FOnFolderChanged : TVpFolderChangedEvent;
FOnFolderClick : TVpFolderClickEvent;
FOnItemClick : TVpItemClickEvent;
FOnMouseOverItem : TVpMouseOverItemEvent;
{internal variables}
nabChanging : Boolean;
nabEdit : TVpRenameEdit;
nabTopItem : Integer;
nabExternalDrag : Boolean;
nabDragFromItem : Integer;
nabDragFromFolder : Integer;
nabDragToItem : Integer;
nabDragToFolder : Integer;
nabDropY : Integer;
nabHitTest : TPoint; {location of mouse cursor}
nabItemsRect : TRect;
nabMouseDown : Boolean;
nabOverButton : Boolean;
nabScrollDownBtn : TSpeedButton;
nabScrollUpBtn : TSpeedButton;
nabTimer : Integer; {timer-pool handle}
nabExternalDragItem : Integer;
nabFolderAccept : Boolean;
nabItemAccept : Boolean;
nabCursorOverItem : Boolean;
nabAcceptAny : Boolean;
nabLastMouseOverItem: Integer;
{property methods}
function GetFolder(Index : Integer) : TVpNavFolder;
function GetFolderCount : Integer;
function GetContainer(Index: Integer):TVpFolderContainer;
procedure SetActiveFolder(Value : Integer);
procedure SetBackgroundColor(Value : TColor);
procedure SetBackgroundImage(Value : TBitmap);
procedure SetBackgroundMethod(Value : TVpBackgroundMethod);
procedure SetDrawingStyle(Value : TVpFolderDrawingStyle);
procedure SetBorderStyle(const Value : TBorderStyle);
procedure SetButtonHeight(Value : Integer);
procedure SetImages(Value : TImageList);
procedure SetItemFont(Value : TFont);
procedure SetItemSpacing(Value : Word);
procedure SetSelectedItemFont(Value : TFont);
procedure SetScrollDelta(Value : Integer);
{internal methods}
function nabButtonRect(Index : Integer) : TRect;
procedure nabCommitEdit(Sender : TObject);
procedure DragOver(Source: TObject;
X, Y: Integer;
State: TDragState;
var Accept: Boolean); override;
function nabDropHitTest(X, Y : Integer) : Boolean;
procedure nabFolderChange(Sender : TObject);
procedure nabFolderSelected(Sender : TObject; Index : Integer);
procedure nabFontChanged(Sender : TObject);
procedure nabGetEditorCaption(var Caption : string);
function nabGetFolderArea(Index : Integer) : TRect;
procedure nabGetHitTest(X, Y : Integer;
var FolderIndex : Integer;
var ItemIndex : Integer);
procedure nabImagesChanged(Sender : TObject);
procedure nabRecalcDisplayNames;
procedure nabScrollDownBtnClick(Sender : TObject);
procedure nabScrollUpBtnClick(Sender : TObject);
function nabShowScrollUp : Boolean;
function nabShowScrollDown : Boolean;
procedure nabTimerEvent(Sender : TObject;
Handle : Integer;
Interval : Cardinal;
ElapsedTime : LongInt);
{VCL message methods}
{$IFNDEF LCL}
procedure CMCtl3DChanged(var Msg : TMessage); message CM_CTL3DCHANGED;
procedure CMDesignHitTest(var Msg : TCMDesignHitTest); message CM_DESIGNHITTEST;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CMParentColorChanged(var Message: TMessage); message CM_PARENTCOLORCHANGED;
{windows message response methods}
procedure WMEraseBkGnd(var Msg : TWMEraseBkGnd); message WM_ERASEBKGND;
procedure WMGetDlgCode(var Msg : TWMGetDlgCode); message WM_GETDLGCODE;
procedure WMNCHitTest(var Msg : TWMNCHitTest); message WM_NCHITTEST;
procedure WMSetCursor(var Msg : TWMSetCursor); message WM_SETCURSOR;
{$ELSE}
procedure CMFontChanged(var Message: TLMessage); message CM_FONTCHANGED;
procedure CMParentColorChanged(var Message: TLMessage); message CM_PARENTCOLORCHANGED;
{windows message response methods}
procedure WMEraseBkGnd(var Msg : TLMEraseBkGnd); message LM_ERASEBKGND;
procedure WMNCHitTest(var Msg : TLMNCHitTest); message LM_NCHITTEST;
{$ENDIF}
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
{Compound component streaming methods}
procedure Loaded; override;
procedure GetChildren(Proc: TGetChildProc; Root: TComponent); override;
function GetChildOwner: TComponent; override;
function AddContainer(Container: TVpFOlderContainer): Integer;
procedure RemoveContainer(Container: TVpFolderContainer);
procedure MouseDown(Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer); override;
procedure MouseMove(Shift: TShiftState; X, Y: Integer); override;
procedure MouseUp(Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer); override;
procedure Notification(AComponent : TComponent;
Operation : TOperation); override;
procedure Paint; override;
procedure DoArrange;
procedure DoFolderChange(Index : Integer; var AllowChange : Boolean);
procedure DoFolderChanged(Index : Integer);
procedure DoFolderClick(Button : TMouseButton;
Shift : TShiftState;
Index : Integer);
procedure DoItemClick(Button : TMouseButton;
Shift : TShiftState;
Index : Integer);
procedure DoMouseOverItem(X, Y, ItemIndex : Integer);
{properties}
property ActiveFolder : Integer
read FActiveFolder write SetActiveFolder;
property AllowRearrange : Boolean
read FAllowRearrange write FAllowRearrange;
property BackgroundColor : TColor
read FBackgroundColor write SetBackgroundColor;
property BackgroundImage : TBitmap
read FBackgroundImage write SetBackgroundImage;
property BackgroundMethod : TVpBackgroundMethod
read FBackgroundMethod write SetBackgroundMethod;
property BorderStyle : TBorderStyle
read FBorderStyle write SetBorderStyle;
property ButtonHeight : Integer
read FButtonHeight write SetButtonHeight;
property DrawingStyle : TVpFolderDrawingStyle
read FDrawingStyle write SetDrawingStyle;
property FolderCollection : TVpCollection
read FFolders write FFolders;
property Images : TImageList
read FImages write SetImages;
property ItemFont : TFont
read FItemFont write SetItemFont;
property ItemSpacing : Word
read FItemSpacing write SetItemSpacing;
property PlaySounds : Boolean
read FPlaySounds write FPlaySounds;
property ScrollDelta : Integer
read FScrollDelta write SetScrollDelta default 2;
property SelectedItem : Integer
read FSelectedItem write FSelectedItem;
property SelectedItemFont : TFont
read FSelectedItemFont write SetSelectedItemFont;
property ShowButtons : Boolean
read FShowButtons write FShowButtons;
property SoundAlias : string
read FSoundAlias write FSoundAlias;
{ property Storage : TOvcAbstractStore
read FStorage write SetStorage;}
{inherited Events}
property AfterEnter;
property AfterExit;
property OnMouseWheel;
{events}
property OnArrange : TNotifyEvent
read FOnArrange write FOnArrange;
property OnDragDrop : TVpNABDragDropEvent
read FOnDragDrop write FOnDragDrop;
property OnDragOver : TVpNABDragOverEvent
read FOnDragOver write FOnDragOver;
property OnFolderClick : TVpFolderClickEvent
read FOnFolderClick write FOnFolderClick;
property OnItemClick : TVpItemClickEvent
read FOnItemClick write FOnItemClick;
property OnFolderChange : TVpFolderChangeEvent
read FOnFolderChange write FOnFolderChange;
property OnFolderChanged : TVpFolderChangedEvent
read FOnFolderChanged write FOnFolderChanged;
property OnMouseOverItem : TVpMouseOverItemEvent
read FOnMouseOverItem write FOnMouseOverItem;
public
constructor Create(AOwner : TComponent); override;
destructor Destroy; override;
procedure SetBounds(ALeft, ATop, AWidth, AHeight : Integer); override;
{ Declared public because TControl's DragDrop is public. }
procedure DragDrop(Source: TObject; X, Y: Integer); override;
procedure BeginUpdate;
procedure ItemChanged(FolderIndex, ItemIndex: Integer);
procedure FolderChanged(FolderIndex: Integer);
procedure EndUpdate;
function GetFolderAt(X, Y : Integer) : Integer;
function GetItemAt(X, Y : Integer) : Integer;
function Container: TVpFolderContainer;
procedure InsertFolder(const ACaption : string; AFolderIndex : Integer);
procedure AddFolder(const ACaption : string);
procedure RemoveFolder(AFolderIndex : Integer);
procedure RenameFolder(AFolderIndex : Integer);
procedure InsertItem(const ACaption : string; AFolderIndex, AItemIndex,
AIconIndex : Integer);
procedure AddItem(const ACaption : string; AFolderIndex,
AIconIndex : Integer);
procedure RemoveItem(AFolderIndex, AItemIndex : Integer);
procedure InvalidateItem(FolderIndex, ItemIndex : Integer);
procedure RenameItem(AFolderIndex, AItemIndex : Integer);
property ActiveItem : Integer
read FActiveItem;
property Containers[Index: Integer]: TVpFolderContainer
read GetContainer;
property Folders[Index : Integer] : TVpNavFolder
read GetFolder;
property FolderCount : Integer
read GetFolderCount;
property PreviousFolder : Integer
read FPreviousFolder;
property PreviousItem : Integer
read FPreviousItem;
end;
TVpNavBar = class(TVpCustomNavBar)
published
property ActiveFolder;
property AllowRearrange;
property BackgroundColor;
property BackgroundImage;
property BackgroundMethod;
property BorderStyle;
property ButtonHeight;
property DrawingStyle;
property FolderCollection;
property Images;
property ItemFont;
property ItemSpacing;
property PlaySounds;
property ScrollDelta;
property SelectedItem;
property SelectedItemFont;
property ShowButtons;
property SoundAlias;
// property Storage;
{inherited Events}
property AfterEnter;
property AfterExit;
property OnMouseWheel;
{events}
property OnArrange;
property OnDragDrop;
property OnDragOver;
property OnFolderClick;
property OnItemClick;
property OnFolderChange;
property OnFolderChanged;
property OnMouseOverItem;
{inherited properties}
{$IFDEF VERSION4}
property Anchors;
property Constraints;
property DragKind;
{$ENDIF}
property Align;
property DragCursor;
property Enabled;
property Font;
(*
The following properties are not published to avoid conflicts with
OnFolderClick and OnItemClick.
property OnClick;
property OnDblClick;
*)
property OnEndDrag;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
property ParentColor;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property Visible;
end;
implementation
const
nabTimerInterval = 200;
{DrawNavTab - returns the usable text area inside the tab rect.}
function DrawNavTab(Canvas: TCanvas;
const Client: TRect;
BevelWidth: Integer;
TabColor: TColor;
TabNumber: Integer;
CoolTab,
IsFocused,
IsMouseOver: Boolean): TRect;
var
R: TRect;
{$IFNDEF VERSION4}
Points: array[1..5] of TPoint;
{$ENDIF}
begin
R := Client;
with Canvas do begin
Brush.Color := clBtnFace;
Brush.Style := bsSolid;
Pen.Color := TabColor;
{fill the tab area}
Polygon([Point(R.Left, R.Bottom),
Point(R.Left, R.Top),
Point(R.Right, R.Top),
Point(R.Right, R.Bottom)]);
if CoolTab then
{Draw Cool Tabs}
begin
Pen.Color := clBlack;
{Draw the bottom, left line}
MoveTo(R.Left, R.Bottom - 1);
LineTo(R.Left + 5, R.Bottom - 1);
{Draw the bottom, left curve}
{$IFNDEF VERSION4}
Points[1] := Point(R.Left + 5, R.Bottom - 1);
Points[2] := Point(R.Left + 11, R.Bottom - 2);
Points[3] := Point(R.Left + 12, R.Bottom - 7);
Points[4] := Point(R.Left + 13, R.Bottom - 9);
{$IFDEF CBuilder}
Canvas.PolyBezier(Points);
{$ELSE}
Canvas.Polyline(Points);
{$ENDIF}
{$ELSE}
PolyBezier([Point(R.Left + 5, R.Bottom - 1), {StartPoint}
Point(R.Left + 11, R.Bottom - 2), {ControlPoint}
Point(R.Left + 12, R.Bottom - 7), {ControlPoint}
Point(R.Left + 13, R.Bottom - 9)]); {EndPoint}
{$ENDIF}
{Draw the left side of the tab}
MoveTo(R.Left + 13, R.Bottom - 9);
LineTo(R.Left + 13, R.Top + 9);
{Draw the top, left corner of the tab}
{$IFNDEF VERSION4}
Points[1] := Point(R.Left + 13, R.Top + 9);
Points[2] := Point(R.Left + 14, R.Top + 7);
Points[3] := Point(R.Left + 15, R.Top + 2);
Points[4] := Point(R.Left + 21, R.Top + 1);
{$IFDEF CBuilder}
Canvas.PolyBezier(Points);
{$ELSE}
Canvas.Polyline(Points);
{$ENDIF}
{$ELSE}
PolyBezier([Point(R.Left + 13, R.Top + 9), {StartPoint}
Point(R.Left + 14, R.Top + 7), {ControlPoint}
Point(R.Left + 15, R.Top + 2), {ControlPoint}
Point(R.Left + 21, R.Top + 1)]); {EndPoint}
{$ENDIF}
{Draw the top of the tab}
MoveTo(R.Left + 21, R.Top + 1);
LineTo(R.Right - 16, R.Top + 1);
{Draw the Top, Right corner of the tab}
{$IFNDEF VERSION4}
Points[1] := Point(R.Right - 16, R.Top + 1);
Points[2] := Point(R.Right - 10, R.Top + 2);
Points[3] := Point(R.Right - 9, R.Top + 7);
Points[4] := Point(R.Right - 8, R.Top + 9);
{$IFDEF CBuilder}
Canvas.PolyBezier(Points);
{$ELSE}
Canvas.Polyline(Points);
{$ENDIF}
{$ELSE}
PolyBezier([Point(R.Right - 16, R.Top + 1), {StartPoint}
Point(R.Right - 10, R.Top + 2), {ControlPoint}
Point(R.Right - 9, R.Top + 7), {ControlPoint}
Point(R.Right - 8, R.Top + 9)]); {EndPoint}
{$ENDIF}
{Draw the right side of the tab}
MoveTo(R.Right - 8, R.Top + 9);
LineTo(R.Right - 8, R.Bottom - 9);
{Draw the bottom, Right curve of the tab which should finish against the
right side.}
{$IFNDEF VERSION4}
Points[1] := Point(R.Right - 8, R.Bottom - 9);
Points[2] := Point(R.Right - 7, R.Bottom - 7);
Points[3] := Point(R.Right - 6, R.Bottom - 2);
Points[4] := Point(R.Right, R.Bottom - 1);
{$IFDEF CBuilder}
Canvas.PolyBezier(Points);
{$ELSE}
Canvas.Polyline(Points);
{$ENDIF}
{$ELSE}
PolyBezier([Point(R.Right - 8, R.Bottom - 9), {StartPoint}
Point(R.Right - 7, R.Bottom - 7), {ControlPoint}
Point(R.Right - 6, R.Bottom - 2), {ControlPoint}
Point(R.Right, R.Bottom - 1)]); {EndPoint}
{$ENDIF}
end else begin
{Draw Standard Tabs}
if TabNumber > 0 then begin
Brush.Color := TabColor;
Brush.Style := bsSolid;
Pen.Color := TabColor;
{fill the tab area}
Polygon([Point(R.Left, R.Bottom),
Point(R.Left, R.Top),
Point(R.Right, R.Top),
Point(R.Right, R.Bottom)]);
end;
Brush.Color := TabColor;
Brush.Style := bsSolid;
{Draw Tab}
Pen.Color := TabColor;
Polygon([Point(R.Left + 10, R.Bottom - 1),
Point(R.Left + 10, R.Top + 3),
Point(R.Left + 12, R.Top + 1),
Point(R.Right-4, R.Top+1),
Point(R.Right-2, R.Top+3),
Point(R.Right-2, R.Bottom-1)]);
{highlight tab}
Pen.Color := clBtnHighlight;
PolyLine([Point(R.Left, R.Bottom - 2),
Point(R.Left + 8, R.Bottom - 2),
Point(R.Left + 9, R.Bottom - 3),
Point(R.Left + 9, R.Top + 3),
Point(R.Left + 11, R.Top + 1),
Point(R.Right - 1, R.Top + 1)]);
{draw border}
Pen.Color := clBlack;
PolyLine([Point(R.Left, R.Bottom - 1),
Point(R.Left + 9, R.Bottom - 1),
Point(R.Left + 10, R.Bottom - 2),
Point(R.Left + 10, R.Top + 4),
Point(R.Left + 11, R.Top + 3),
Point(R.Left + 12, R.Top + 2),
Point(R.Right-2, R.Top + 2),
Point(R.Right-1, R.Top + 3),
Point(R.Right-1, R.Bottom-1)]);
{draw shadow}
end;
end;
Result := Rect(Client.Left + 1, Client.Top + 1,
Client.Right - 2, Client.Bottom - 2);
if IsFocused then OffsetRect(Result, 1, 1);
end;
{===== TVpFolderContainer ===========================================}
constructor TVpFolderContainer.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FNavBar := TVpCustomNavBar(AOwner);
Width := 0;
Height := 0;
Visible := false;
{Add self to container list}
FIndex := FNavBar.AddContainer(Self);
end;
{=====}
destructor TVpFolderContainer.Destroy;
begin
{FComponentList.Free;}
inherited;
end;
{=====}
function TVpFolderContainer.GetChildOwner: TComponent;
begin
Result := Owner.Owner;
end;
{=====}
procedure TVpFolderContainer.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I: Integer;
C: TControl;
begin
inherited GetChildren(Proc, Self);
for I := 0 to ControlCount - 1 do begin
C := Controls[I];
C.Parent := Self;
Proc(C);
end;
end;
{===== TRenameEdit ===================================================}
constructor TVpRenameEdit.Create(AOwner : TComponent);
begin
inherited Create(AOwner);
Visible := False;
WantReturns := False;
FolderIndex := -1;
ItemIndex := -1;
end;
{=====}
procedure TVpRenameEdit.KeyPress(var Key: Char);
begin
if Key = #13 then begin
Key := #0;
DoExit;
end else if Key = #27 then begin
FolderIndex := -1;
ItemIndex := -1;
Key := #0;
DoExit;
end;
end;
{===== Miscellaneous routines ========================================}
function RectWidth(Rect : TRect) : Integer;
begin
Result := Rect.Right - Rect.Left;
end;
{=====}
function RectHeight(Rect : TRect) : Integer;
begin
Result := Rect.Bottom - Rect.Top;
end;
{===== TVpNavBtnItem ===============================================}
constructor TVpNavBtnItem.Create(Collection : TCollection);
begin
inherited Create(Collection);
FFolder := TVpNavFolder((TVpCollection(Collection)).GetOwner);
FIconIndex := -1;
Name := 'Item' + IntToStr(FFolder.Index) + '-' + IntToStr(Index);
FFolder.FNavBar.Invalidate;
end;
{=====}
destructor TVpNavBtnItem.Destroy;
var
NaBar: TVpCustomNavBar;
FolderIndex: Integer;
begin
NaBar := FFolder.FNavBar;
FolderIndex := FFolder.Index;
inherited Destroy;
NaBar.FolderChanged(FolderIndex);
end;
{=====}
procedure TVpNavBtnItem.Assign(Source: TPersistent);
begin
if Source is TVpNavBtnItem then begin
Caption := TVpNavBtnItem(Source).Caption;
Description := TVpNavBtnItem(Source).Description;
IconIndex := TVpNavBtnItem(Source).IconIndex;
Tag := TVpNavBtnItem(Source).Tag;
end else
inherited Assign(Source);
end;
{=====}
procedure TVpNavBtnItem.SetCaption(const Value : string);
begin
if Value <> FCaption then begin
FCaption := Value;
Changed(false);
FFolder.FNavBar.ItemChanged(FFolder.Index, Index);
end;
end;
{=====}
procedure TVpNavBtnItem.SetIconIndex(Value : Integer);
begin
if Value <> FIconIndex then begin
FIconIndex := Value;
Changed(false);
FFolder.FNavBar.ItemChanged(FFolder.Index, Index);
end;
end;
{===== TVpNavBtnFolder =============================================}
constructor TVpNavFolder.Create(Collection : TCollection);
begin
inherited Create(Collection);
RegisterClass(TVpFolderContainer);
FNavBar := TVpCustomNavBar(TVpCollection(Collection).GetOwner);
FNavBar.ActiveFolder := Index;
FItems := TVpCollection.Create(Self, TVpNavBtnItem);
Name := 'NavFolder' + IntToStr(Index);
FEnabled := True;
FIconSize := isLarge;
end;
{=====}
destructor TVpNavFolder.Destroy;
begin
{Change the Active Folder to one that will still exist}
if not(csDestroying in FNavBar.ComponentState) then begin
if Index > 0 then
FNavBar.ActiveFolder := Index - 1
else if Collection.Count > 1 then
FNavBar.ActiveFolder := 0
else
FNavBar.ActiveFolder := -1;
FNavBar.FolderChanged(Index);
end;
FItems.Free;
FItems := nil;
inherited Destroy;
end;
{=====}
function TVpNavFolder.GetItem(Index : Integer) : TVpNavBtnItem;
begin
Result := TVpNavBtnItem(FItems[Index]);
end;
{=====}
function TVpNavFolder.GetItemCount : Integer;
begin
Result := FItems.Count;
end;
{=====}
function TVpNavFolder.GetContainer: TVpFolderContainer;
begin
if FolderType = ftContainer then
result := FNavBar.FContainers[FContainerIndex]
else
result := nil;
end;
{=====}
procedure TVpNavFolder.lfGetEditorCaption(var Caption : string);
begin
Caption := RSEditingItems;
end;
{=====}
procedure TVpNavFolder.lfItemChange(Sender : TObject);
begin
if (TVpCollection(Collection).GetOwner is TComponent) then
if not (csDestroying in
TComponent(TVpCollection(Collection).GetOwner).ComponentState)
then begin
TVpNavBar(TVpCollection(Collection).GetOwner).nabRecalcDisplayNames;
TVpNavBar(TVpCollection(Collection).GetOwner).Invalidate;
end;
end;
{=====}
procedure TVpNavFolder.DefineProperties(Filer: TFiler);
begin
Filer.DefineProperty('ContainerIndex', ReadIndex, WriteIndex,
FFolderType = ftContainer);
end;
{=====}
procedure TVpNavFolder.ReadIndex(Reader: TReader);
begin
ContainerIndex := trunc(Reader.ReadFloat);
end;
{=====}
procedure TVpNavFolder.WriteIndex(Writer: TWriter);
begin
Writer.WriteFloat(ContainerIndex);
end;
{=====}
procedure TVpNavFolder.SetCaption(const Value : string);
begin
if FCaption <> Value then begin
FCaption := Value;
Changed(false);
FNavBar.FolderChanged(Index);
end;
end;
{=====}
procedure TVpNavFolder.SetEnabled(Value : Boolean);
begin
if Value <> FEnabled then begin
FEnabled := Value;
Changed(false);
FNavBar.FolderChanged(Index);
end;
end;
{=====}
procedure TVpNavFolder.SetFolderType(Value: TVpFolderType);
begin
if Value <> FFolderType then begin
FFolderType := Value;
if not (csLoading in FNavBar.ComponentState) then begin
if FFolderType = ftContainer then
ContainerIndex := CreateContainer
else begin
FNavBar.FContainers.Delete(FContainerIndex);
FContainerIndex := -1;
end;
FNavBar.FolderChanged(Index);
end;
end;
end;
{=====}
function TVpNavFolder.CreateContainer: Integer;
var
New: TVpFolderContainer;
begin
New := TVpFolderContainer.Create(FNavBar);
New.Parent := FNavBar;
result := New.Index;
New.Name := 'Container' + IntToStr(Result);
New.Caption := '';
New.BevelOuter := bvNone;
New.BevelInner := bvNone;
New.Color := FNavBar.FBackgroundColor;
end;
{=====}
procedure TVpNavFolder.SetIconSize(Value : TVpIconSize);
begin
if FIconSize <> Value then begin
FIconSize := Value;
Changed(false);
FNavBar.FolderChanged(Index);
end;
end;
{=====}
procedure TVpNavFolder.SetItem(Index : Integer; Value : TVpNavBtnItem);
begin
SetItem(Index, Value);
end;
{===== TVpNavBar ================================================}
constructor TVpCustomNavBar.Create(AOwner : TComponent);
var
HSnd : THandle;
begin
inherited Create(AOwner);
FContainers := TVpContainerList.Create(Self);
FLoadingFolder := -1;
FShowButtons := True;
if Classes.GetClass(TVpNavFolder.ClassName) = nil then
Classes.RegisterClass(TVpNavFolder);
if Classes.GetClass(TVpNavBtnItem.ClassName) = nil then
Classes.RegisterClass(TVpNavBtnItem);
FFolders := TVpCollection.Create(Self, TVpNavFolder);
FFolders.OnChanged := nabFolderChange;
FFolders.OnGetEditorCaption := nabGetEditorCaption;
FFolders.OnItemSelected := nabFolderSelected;
FItemFont := TFont.Create;
FItemFont.Name := Font.Name;
FItemFont.OnChange := nabFontChanged;
FItemFont.Color := clWhite;
FItemSpacing := abs(FItemFont.Height) + 3;
FSelectedItemFont := TFont.Create;
FSelectedItemFont.Name := Font.Name;
FSelectedItemFont.OnChange := nabFontChanged;
FSelectedItemFont.Color := FItemFont.Color;
FSelectedItemFont.Style := FItemFont.Style;
FSelectedItemFont.Size := FItemFont.Size;
{force drivers to load by playing empty wave data}
{ HSnd := FindResource(HInstance, 'VPEMPTYWAVE', RT_RCDATA);
if HSnd > 0 then begin
HSnd := LoadResource(HInstance, HSnd);
if HSnd > 0 then begin
sndPlaySound(LockResource(HSnd), SND_ASYNC or SND_MEMORY);
FreeResource(HSnd);
end;
end;}
nabScrollUpBtn := TSpeedButton.Create(Self);
with nabScrollUpBtn do begin
Visible := False;
Parent := Self;
OnClick := nabScrollUpBtnClick;
Glyph.Handle := LoadBaseBitmap('VPUPARROW');
NumGlyphs := 1;
Left := -20;
Height := 15;
Width := 17;
end;
nabScrollDownBtn := TSpeedButton.Create(Self);
with nabScrollDownBtn do begin
Visible := False;
Parent := Self;
OnClick := nabScrollDownBtnClick;
Glyph.Handle := LoadBaseBitmap('VPDOWNARROW');
NumGlyphs := 1;
Left := -20;
Height := 15;
Width := 17;
end;
{create edit control}
if not (csDesigning in ComponentState) then begin
nabEdit := TVpRenameEdit.Create(Self);
nabEdit.Parent := Self;
nabEdit.OnExit := nabCommitEdit;
end;
Height := 240;
Width := 120;
ParentColor := False;
FAllowRearrange := True;
FBackgroundColor := clInactiveCaption;
FBackgroundImage := TBitmap.Create;
FBackgroundMethod := bmNormal;
FBorderStyle := bsSingle;
FButtonHeight := 20;
FActiveFolder := -1;
FActiveItem := -1;
FSelectedItem := -1;
FHotFolder := -1;
FPreviousFolder := -1;
FPreviousItem := -1;
FPlaySounds := False;
FScrollDelta := 2;
FSoundAlias := 'MenuCommand';
nabMouseDown := False;
nabChanging := False;
nabTopItem := 0;
nabDragFromItem := -1;
nabDragFromFolder := -1;
nabDropY := -1;
nabTimer := -1;
nabLastMouseOverItem := -1;
end;
{=====}
destructor TVpCustomNavBar.Destroy;
begin
Images := nil; {unregister any image list notification}
nabChanging := True;
nabEdit.Free;
FContainers.Free;
FFolders.Free;
FFolders := nil;
FItemFont.Free;
FItemFont := nil;
FSelectedItemFont.Free;
FSelectedItemFont := nil;
FBackgroundImage.Free;
FBackgroundImage := nil;
inherited Destroy;
end;
{=====}
procedure TVpCustomNavBar.BeginUpdate;
begin
nabChanging := True;
end;
{=====}
procedure TVpCustomNavBar.ItemChanged(FolderIndex, ItemIndex: Integer);
begin
InvalidateItem(FolderIndex, ItemIndex);
if not (csDestroying in ComponentState) then
RecreateWnd{$IFDEF LCL}(self){$ENDIF};
end;
{=====}
procedure TVpCustomNavBar.FolderChanged(FolderIndex: Integer);
begin
Invalidate;
if not (csDestroying in ComponentState) then
RecreateWnd{$IFDEF LCL}(self){$ENDIF};
end;
{=====}
{$IFNDEF LCL}
procedure TVpCustomNavBar.CMDesignHitTest(var Msg : TCMDesignHitTest);
begin
Msg.Result := LongInt(nabOverButton);
end;
{$ENDIF}
{=====}
procedure TVpCustomNavBar.CMFontChanged(var Message: {$IFDEF LCL}TLMessage{$ELSE}TMessage{$ENDIF});
begin
nabRecalcDisplayNames;
end;
{=====}
procedure TVpCustomNavBar.CMParentColorChanged(var Message: {$IFDEF LCL}TLMessage{$ELSE}TMessage{$ENDIF});
begin
inherited;
if ParentColor then
SetBackgroundColor(Color);
end;
{=====}
procedure TVpCustomNavBar.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do
Style := LongInt(Style) or BorderStyles[FBorderStyle];
if NewStyleControls {and Ctl3D }and (FBorderStyle = bsSingle) then begin
Params.Style := Params.Style and not WS_BORDER;
Params.ExStyle := Params.ExStyle or WS_EX_CLIENTEDGE;
end;
end;
{=====}
procedure TVpCustomNavBar.CreateWnd;
begin
if (csDestroying in ComponentState) then exit;
inherited CreateWnd;
nabRecalcDisplayNames;
end;
{=====}
procedure TVpCustomNavBar.Loaded;
begin
inherited Loaded;
if DrawingStyle = dsEtchedButton then
BorderStyle := bsNone;
if FolderCollection.Count > 0 then
FActiveFolder := 0
else
FActiveFolder := -1;
end;
{=====}
procedure TVpCustomNavBar.GetChildren(Proc: TGetChildProc; Root: TComponent);
var
I: Integer;
begin
for I := 0 to FContainers.Count - 1 do
Proc(TComponent(FContainers[I]));
end;
{=====}
function TVpCustomNavBar.AddContainer(
Container: TVpFolderContainer): Integer;
begin
result := FContainers.Add(Container);
end;
{=====}
procedure TVpCustomNavBar.RemoveContainer(Container: TVpFolderContainer);
begin
FContainers.Remove(Container);
Container.Free;
end;
{=====}
procedure TVpCustomNavBar.DoArrange;
begin
if Assigned(FOnArrange) then
FOnArrange(Self);
end;
{=====}
procedure TVpCustomNavBar.DoFolderChange(Index : Integer;
var AllowChange: Boolean);
begin
if Assigned(FOnFolderChange) then
FOnFolderChange(Self, Index, AllowChange, nabDragFromItem <> -1);
end;
{=====}
procedure TVpCustomNavBar.DoFolderChanged(Index : Integer);
begin
if Assigned(FOnFolderChanged) then
FOnFolderChanged(Self, Index);
end;
{=====}
procedure TVpCustomNavBar.DoFolderClick(Button : TMouseButton;
Shift : TShiftState;
Index : Integer);
begin
if Assigned(FOnFolderClick) then
FOnFolderClick(Self, Button, Shift, Index);
end;
{=====}
procedure TVpCustomNavBar.DoItemClick(Button : TMouseButton;
Shift : TShiftState;
Index : Integer);
begin
if Assigned(FOnItemClick) then
FOnItemClick(Self, Button, Shift, Index);
end;
{=====}
procedure TVpCustomNavBar.DoMouseOverItem(X, Y, ItemIndex : Integer);
begin
if Assigned(FOnMouseOverItem) then
FOnMouseOverItem(Self,
Folders[ActiveFolder].Items[GetItemAt(X, Y)]);
end;
{=====}
procedure TVpCustomNavBar.EndUpdate;
begin
nabChanging := False;
nabRecalcDisplayNames;
end;
{=====}
function TVpCustomNavBar.GetFolderCount : Integer;
begin
Result := FFolders.Count;
end;
{=====}
function TVpCustomNavBar.GetFolder(Index : Integer) : TVpNavFolder;
begin
Result := TVpNavFolder(FFolders.GetItem(Index));
end;
{=====}
function TVpCustomNavBar.GetFolderAt(X, Y : Integer) : Integer;
var
Dummy : Integer;
begin
nabGetHitTest(X, Y, Result, Dummy);
end;
{=====}
function TVpCustomNavBar.GetContainer(Index: Integer):TVpFolderContainer;
begin
try
result := FContainers[Index];
except
result := nil;
end;
end;
{=====}
function TVpCustomNavBar.GetItemAt(X, Y : Integer) : Integer;
var
Dummy : Integer;
begin
nabGetHitTest(X, Y, Dummy, Result);
end;
{=====}
function TVpCustomNavBar.Container: TVpFolderContainer;
begin
if Folders[FActiveFolder].FolderType = ftContainer then
result := FContainers[Folders[FActiveFolder].ContainerIndex]
else
result := nil;
end;
{=====}
procedure TVpCustomNavBar.InsertFolder(const ACaption : string;
AFolderIndex : Integer);
{$IFNDEF VERSION4}
var
I : Integer;
{$ENDIF}
begin
{$IFNDEF VERSION4}
FFolders.Add;
for I := AFolderIndex to FFolders.Count - 2 do begin
Folders[I].Index := I + 1;
end;
Folders[FFolders.Count - 1].Index := AFolderIndex;
{$ELSE}
FFolders.Insert(AFolderIndex);
{$ENDIF}
Folders[AFolderIndex].Caption := ACaption;
if FolderCount = 1 then begin
FActiveFolder := 0;
FActiveItem := -1;
FSelectedItem := -1;
end;
nabRecalcDisplayNames;
end;
{=====}
procedure TVpCustomNavBar.AddFolder(const ACaption : string);
var
NewFolder: TVpNavFolder;
begin
NewFolder := TVpNavFolder(FFolders.Add);
NewFolder.Caption := ACaption;
if FolderCount = 1 then begin
FActiveFolder := 0;
FActiveItem := -1;
FSelectedItem := -1;
end;
nabRecalcDisplayNames;
end;
{=====}
procedure TVpCustomNavBar.RemoveFolder(AFolderIndex : Integer);
var
Folder: TVpNavFolder;
begin
Folder := TVpNavFolder(FolderCollection.Items[AFolderIndex]);
Folder.Free;
{$IFDEF VERSION5}
FolderCollection.Delete(AFolderIndex);
{$ENDIF}
end;
{=====}
procedure TVpCustomNavBar.RenameFolder(AFolderIndex: Integer);
var
Folder : TVpNavFolder;
begin
Folder := Folders[AFolderIndex];
nabEdit.FolderIndex := AFolderIndex;
nabEdit.ItemIndex := -1;
nabEdit.Font.Size := Font.Size;
nabEdit.BorderStyle := bsNone;
nabEdit.Top := Folder.lfRect.Top+2;
nabEdit.Left := Folder.lfRect.Left+2;
nabEdit.Height := HeightOf(Folder.lfRect)-5;
nabEdit.Width := Folder.lfRect.Right - Folder.lfRect.Left-5;
nabEdit.Visible := True;
nabEdit.Text := Folder.Caption;
nabEdit.SelectAll;
nabEdit.SetFocus;
end;
{=====}
procedure TVpCustomNavBar.InsertItem(const ACaption : string;
AFolderIndex, AItemIndex,
AIconIndex : Integer);
var
AFolder : TVpNavFolder;
{$IFNDEF VERSION4}
I : Integer;
{$ENDIF}
begin
AFolder := Folders[AFolderIndex];
{$IFNDEF VERSION4}
AFolder.FItems.Add;
for I := AFolderIndex to AFolder.FItems.Count - 2 do
AFolder.Items[I].Index := I + 1;
AFolder.Items[AFolder.FItems.Count-1].Index := AFolderIndex;
{$ELSE}
AFolder.FItems.Insert(AItemIndex);
{$ENDIF}
AFolder.Items[AItemIndex].Caption := ACaption;
AFolder.Items[AItemIndex].IconIndex := AIconIndex;
Invalidate;
end;
{=====}
procedure TVpCustomNavBar.AddItem(const ACaption : string;
AFolderIndex,
AIconIndex : Integer);
var
AFolder : TVpNavFolder;
AItem: TVpNavBtnItem;
begin
AFolder := Folders[AFolderIndex];
AItem := TVpNavBtnItem(AFolder.FItems.Add);
AItem.Caption := ACaption;
AItem.IconIndex := AIconIndex;
Invalidate;
end;
{=====}
procedure TVpCustomNavBar.RemoveItem(AFolderIndex, AItemIndex : Integer);
var
Folder : TVpNavFolder;
begin
Folder := TVpNavFolder(FolderCollection.GetItem(AFolderIndex));
Folder.Items[AItemIndex].Free;
{$IFDEF VERSION5}
FolderCollection.Delete(AItemIndex);
{$ENDIF}
end;
{=====}
procedure TVpCustomNavBar.InvalidateItem(FolderIndex, ItemIndex : Integer);
var
F : TRect;
R : TRect;
begin
R := TVpNavBtnItem(Folders[FolderIndex].Items[ItemIndex]).FIconRect;
{expand rect}
Dec(R.Top);
Dec(R.Left);
Inc(R.Bottom, 2);
Inc(R.Right, 2);
{ Might be a hidden folder. }
if (not ((FolderCount = 1) and (Folders[0].Caption = '')))
or (csDesigning in ComponentState) then
F := nabGetFolderArea(FolderIndex)
else
F := R;
R.Top := Max(R.Top, F.Top);
R.Bottom := Min(R.Bottom, F.Bottom);
if RectHeight(R) > 0 then
InvalidateRect(Handle, @R, False);
end;
{=====}
procedure TVpCustomNavBar.RenameItem(AFolderIndex, AItemIndex : Integer);
var
Item : TVpNavBtnItem;
begin
Item := Folders[AFolderIndex].Items[AItemIndex];
nabEdit.FolderIndex := AFolderIndex;
nabEdit.ItemIndex := AItemIndex;
nabEdit.Font.Size := ItemFont.Size;
nabEdit.Font.Size := ItemFont.Size;
nabEdit.BorderStyle := bsSingle;
nabEdit.Top := Item.LabelRect.Top-1;
nabEdit.Left := 10;
nabEdit.Height := HeightOf(Item.LabelRect) + 2;
nabEdit.Width := Width - 24;
nabEdit.Visible := True;
nabEdit.Text := Item.Caption;
nabEdit.SelectAll;
nabEdit.SetFocus;
end;
{=====}
function GetLargeIconDisplayName(Canvas : TCanvas;
Rect : TRect;
const Name : string) : string;
{-given a string, and a rectangle, find the string that can be displayed
using two lines. Add ellipsis to the end of each line if necessary and
possible}
var
TestRect : TRect;
SH, DH : Integer;
Buf : array[0..255] of Char;
I : Integer;
TempName : string;
Temp2 : string;
begin
TempName := Trim(Name);
{get single line height}
with TestRect do begin
Left := 0;
Top := 0;
Right := 1;
Bottom := 1;
end;
SH := DrawText(Canvas.Handle, 'W W', 3, TestRect,
DT_SINGLELINE or DT_CALCRECT);
{get double line height}
with TestRect do begin
Left := 0;
Top := 0;
Right := 1;
Bottom := 1;
end;
DH := DrawText(Canvas.Handle, 'W W', 3, TestRect,
DT_WORDBREAK or DT_CALCRECT);
{see if the text can fit within the existing rect without growing}
TestRect := Rect;
StrPLCopy(Buf, TempName, 255);
DrawText(Canvas.Handle, Buf, Length(TempName), TestRect,
DT_WORDBREAK or DT_CALCRECT);
I := Pos(' ', TempName);
if (RectHeight(TestRect) = SH) or (I < 2) then
Result := GetDisplayString(Canvas, TempName, 1, RectWidth(Rect))
else begin
{the first line only has ellipsis if there's only one word on it and
that word won't fit}
Temp2 := GetDisplayString(Canvas, Copy(TempName, 1, I-1), 1,
RectWidth(Rect));
if CompareStr(Temp2, Copy(TempName, 1, I-1)) <> 0 then begin
Result := GetDisplayString(Canvas, Copy(TempName, 1, I-1), 1,
RectWidth(Rect)) +
' ' +
GetDisplayString(Canvas, Copy(TempName, I+1,
Length(TempName) - I), 1, RectWidth(Rect));
end else begin
{2 or more lines, and the first line isn't getting an ellipsis}
if (RectHeight(TestRect) = DH) and
(RectWidth(TestRect) <= RectWidth(Rect)) then
{it will fit}
Result := TempName
else begin
{it won't fit, but the first line wraps OK - 2nd line needs an ellipsis}
TestRect.Right := Rect.Right + 1;
while (RectWidth(TestRect) > RectWidth(Rect)) or
(RectHeight(TestRect) > DH) do begin
if Length(TempName) > 1 then begin
TestRect := Rect;
Delete(TempName, Length(TempName), 1);
TempName := Trim(TempName);
StrPLCopy(Buf, TempName + '...', 255);
DrawText(Canvas.Handle, Buf, Length(TempName) + 3, TestRect,
DT_WORDBREAK or DT_CALCRECT);
Result := TempName + '...';
end else begin
Result := TempName + '..';
TestRect := Rect;
StrPLCopy(Buf, Result, 255);
DrawText(Canvas.Handle, Buf, Length(Result), TestRect,
DT_WORDBREAK or DT_CALCRECT);
if (RectWidth(TestRect) <= RectWidth(Rect)) and
(RectHeight(TestRect) > DH) then
Break;
Result := TempName + '.';
TestRect := Rect;
StrPLCopy(Buf, Result, 255);
DrawText(Canvas.Handle, Buf, Length(Result), TestRect,
DT_WORDBREAK or DT_CALCRECT);
if (RectWidth(TestRect) <= RectWidth(Rect)) and
(RectHeight(TestRect) > DH) then
Break;
Result := TempName;
end;
end;
end;
end;
end;
end;
{=====}
function TVpCustomNavBar.nabButtonRect(Index : Integer) : TRect;
begin
Result := Folders[Index].lfRect;
end;
{=====}
procedure TVpCustomNavBar.nabCommitEdit(Sender : TObject);
var
Folder : TVpNavFolder;
Item : TVpNavBtnItem;
begin
if not Assigned(nabEdit) then
Exit;
if (nabEdit.FolderIndex > -1) then begin
if nabEdit.ItemIndex = -1 then begin
{rename the folder}
Folder := Folders[nabEdit.FolderIndex];
Folder.Caption := nabEdit.Text;
end else begin
Item := Folders[nabEdit.FolderIndex].Items[nabEdit.ItemIndex];
Item.Caption := nabEdit.Text;
end;
end;
nabEdit.FolderIndex := -1;
nabEdit.ItemIndex := -1;
nabEdit.Visible := False;
Update;
end;
{=====}
function TVpCustomNavBar.nabDropHitTest(X, Y : Integer) : Boolean;
{given an X, Y, is this a legal spot to drop a folder?}
var
I : Integer;
SpaceTop : Integer;
SpaceBottom : Integer;
OldDrop : Integer;
Folder : TVpNavFolder;
begin
Result := False;
{assume that X,Y aren't on a folder or item}
OldDrop := nabDropY;
try
nabDragToFolder := -1;
nabDragToItem := -1;
if FolderCount = 0 then
Exit;
Folder := Folders[FActiveFolder];
if Y <= Folder.lfRect.Bottom then
Exit;
if FolderCount > FActiveFolder+1 then
if Y >= Folders[FActiveFolder+1].lfRect.Top then
Exit;
if (X < 0) or (X > ClientWidth) then
Exit;
{we're somewhere in the active folder}
if Folder.ItemCount = 0 then begin
{the active folder is empty}
nabDropY := Folders[FActiveFolder].lfRect.Bottom + 3;
nabDragToFolder := FActiveFolder;
nabDragToItem := 0;
Result := True;
Exit;
end;
for I := nabTopItem to Folder.ItemCount-1 do begin
{is there space above this item?}
if I = nabTopItem then
SpaceTop := Folder.lfRect.Bottom+1
else
SpaceTop := TVpNavBtnItem(Folder.Items[I - 1]).FLabelRect.Bottom + 1;
SpaceBottom := TVpNavBtnItem(Folder.Items[I]).FIconRect.Top - 1;
if (Y >= SpaceTop) and (Y <= SpaceBottom) then begin
if SpaceTop - SpaceBottom < 6 then
nabDropY := SpaceTop + (SpaceBottom - SpaceTop) div 2
else
nabDropY := SpaceTop + 3;
Result := True;
nabDragToFolder := FActiveFolder;
nabDragToItem := I;
nabExternalDragItem := I;
Exit;
end;
end;
{check below the last item...}
SpaceTop :=
TVpNavBtnItem(Folder.Items[Folder.ItemCount - 1]).FLabelRect.Bottom+1;
SpaceBottom := nabItemsRect.Bottom - 1;
if (Y >= SpaceTop) and (Y <= SpaceBottom) then begin
nabDropY := SpaceTop + 3;
nabDragToFolder := FActiveFolder;
nabDragToItem := Folder.ItemCount;
if nabFolderAccept then
nabExternalDragItem := nabDragToItem
else
nabExternalDragItem := Folder.ItemCount - 1;
Result := True;
end;
finally
if (nabDropY <> OldDrop) then
Repaint;
end;
end;
{=====}
procedure TVpCustomNavBar.nabFolderChange(Sender : TObject);
var
ParentForm: TCustomForm;
begin
if not (csDestroying in ComponentState) then begin
if FolderCount = 0 then
FActiveFolder := -1
else begin
if Folders[FActiveFolder].FolderType = ftContainer then begin
ParentForm := GetParentForm(Self);
if ParentForm <> nil then
if ContainsControl(ParentForm.ActiveControl) then
ParentForm.ActiveControl := Self;
end;
if FActiveFolder = -1 then
FActiveFolder := 0;
if FActiveFolder >= FolderCount then
FActiveFolder := 0;
end;
nabTopItem := 0;
nabRecalcDisplayNames;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.nabFolderSelected(Sender : TObject; Index : Integer);
begin
if not (csDestroying in ComponentState) then
ActiveFolder := Index;
end;
{=====}
procedure TVpCustomNavBar.nabFontChanged(Sender : TObject);
begin
Perform(CM_FONTCHANGED, 0, 0);
end;
{=====}
procedure TVpCustomNavBar.nabGetEditorCaption(var Caption : string);
begin
Caption := RSEditingFolders;
end;
{=====}
procedure TVpCustomNavBar.nabGetHitTest(X, Y : Integer;
var FolderIndex : Integer;
var ItemIndex : Integer);
var
I : Integer;
Item : TVpNavBtnItem;
Folder : TVpNavFolder;
begin
FolderIndex := -1;
ItemIndex := -1;
if FolderCount > 0 then begin
{see if we've hit a folder}
for I := 0 to FolderCount-1 do begin
Folder := Folders[I];
if PtInRect(Folder.lfRect, Point(X, Y)) then begin
nabCursorOverItem := False;
FolderIndex := I;
Exit;
end;
end;
{nope, check the active folder to see if we've hit an item}
Folder := Folders[FActiveFolder];
for I := nabTopItem to Folder.ItemCount-1 do begin
Item := Folder.Items[I];
if PtInRect(Item.FIconRect, Point(X,Y)) or
(PtInRect(Item.FLabelRect, Point(X,Y)) and
(Item.Caption <> '')) then begin
if nabExternalDrag then begin
nabCursorOverItem := True;
nabExternalDragItem := I;
end;
ItemIndex := I;
Exit;
end else
if nabExternalDrag then
nabCursorOverItem := False;
end;
end;
end;
{=====}
function TVpCustomNavBar.nabGetFolderArea(Index : Integer) : TRect;
var
I : Integer;
begin
Result := ClientRect;
for I := 0 to ActiveFolder do
Inc(Result.Top, FButtonHeight);
for I := FolderCount-1 downto ActiveFolder+1 do
Dec(Result.Bottom, FButtonHeight);
end;
{=====}
procedure TVpCustomNavBar.nabImagesChanged(Sender : TObject);
begin
Invalidate;
end;
{=====}
procedure TVpCustomNavBar.nabRecalcDisplayNames;
var
I : Integer;
begin
if not HandleAllocated then
exit;
Canvas.Font := Self.Font;
{figure out display names for each folder...}
for I := 0 to FolderCount-1 do
Folders[I].lfDisplayName := GetDisplayString(Canvas, Folders[I].Caption, 1,
ClientWidth);
Invalidate;
end;
{=====}
function TVpCustomNavBar.nabShowScrollDown : Boolean;
var
Folder : TVpNavFolder;
Item : TVpNavBtnItem;
begin
Result := False;
if (FolderCount > 0) then begin
Folder := Folders[FActiveFolder];
if Folder.ItemCount > 0 then begin
Item := Folder.Items[Folder.ItemCount-1];
Result := Item.FLabelRect.Bottom > nabItemsRect.Bottom;
end;
end;
end;
{=====}
procedure TVpCustomNavBar.nabScrollDownBtnClick(Sender : TObject);
begin
if nabShowScrollDown then begin
Inc(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
end;
end;
{=====}
function TVpCustomNavBar.nabShowScrollUp : Boolean;
begin
Result := nabTopItem > 0;
end;
{=====}
procedure TVpCustomNavBar.nabScrollUpBtnClick(Sender : TObject);
begin
if nabTopItem > 0 then begin
Dec(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
end;
end;
{=====}
procedure TVpCustomNavBar.nabTimerEvent(Sender : TObject; Handle : Integer;
Interval : Cardinal; ElapsedTime : LongInt);
var
Pt : TPoint;
Form : TCustomForm;
begin
GetCursorPos(Pt);
Pt := ScreenToClient(Pt);
if not PtInRect(ClientRect, Pt) then begin
if not nabMouseDown then begin
{we're not doing internal dragging anymore}
nabMouseDown := False;
nabDragFromFolder := -1;
nabDragFromItem := -1;
if nabDropY <> -1 then begin
nabDropY := -1;
Repaint;
end;
if FActiveItem <> -1 then begin
InvalidateItem(FActiveFolder, FActiveItem);
FActiveItem := -1;
end;
end else if FAllowRearrange then begin
Form := GetParentForm(Self);
if (Form <> nil) then
if Form.Active then begin
SetCursor(Screen.Cursors[crNoDrop]);
nabDropY := -1;
Repaint;
end;
end;
end else begin
if nabDragFromItem <> -1 then begin
{we're still doing internal dragging - update the cursor}
if nabDropHitTest(Pt.X, Pt.Y) then
SetCursor(Screen.Cursors[DragCursor])
else begin
SetCursor(Screen.Cursors[crNoDrop]);
nabDropY := -1;
Repaint;
end;
end;
end;
end;
{=====}
procedure TVpCustomNavBar.MouseDown(Button : TMouseButton;
Shift : TShiftState;
X, Y : Integer);
begin
{complete any editing}
nabCommitEdit(nil);
{get folder/item clicked}
nabGetHitTest(X, Y, FPreviousFolder, FPreviousItem);
{was it a click on a folder button?}
if FPreviousFolder <> -1 then begin
if Folders[FPreviousFolder].Enabled or
(csDesigning in ComponentState) then begin
if (Button = mbLeft) then begin
nabMouseDown := True;
Invalidate;
end;
Exit;
end;
end;
if FPreviousItem <> -1 then begin
if Folders[FActiveFolder].Enabled or
(csDesigning in ComponentState) then begin
if (Button = mbLeft) then begin
InvalidateItem(FActiveFolder, FPreviousItem);
nabMouseDown := True;
end;
end;
end;
inherited MouseDown(Button, Shift, X, Y);
end;
{=====}
procedure TVpCustomNavBar.MouseMove(Shift : TShiftState; X, Y : Integer);
var
ItemIndex : Integer;
FolderIndex : Integer;
begin
nabGetHitTest(X, Y, FolderIndex, ItemIndex);
{if FActiveItem is valid, and mouse is down, we're starting dragging}
if nabMouseDown or nabExternalDrag then begin
if nabScrollDownBtn.Visible then begin
if Y > nabScrollDownBtn.Top then begin
Inc(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
inherited MouseMove(Shift, X, Y);
Exit;
end;
end;
if nabScrollUpBtn.Visible then begin
if Y < (nabScrollUpBtn.Top + nabScrollUpBtn.Height)then begin
Dec(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
inherited MouseMove(Shift, X, Y);
Exit;
end;
end;
if (FActiveItem <> -1) and (ItemIndex = -1) and FAllowRearrange then begin
nabDragFromFolder := FActiveFolder;
nabDragFromItem := FActiveItem;
if (FolderIndex = -1) then begin
if nabDropHitTest(X, Y) then
SetCursor(Screen.Cursors[DragCursor])
else begin
SetCursor(Screen.Cursors[crNoDrop]);
nabDropY := -1;
Repaint;
end;
end;
end;
if (FolderIndex <> -1) and FAllowRearrange then begin
ActiveFolder := FolderIndex;
nabDropY := -1;
FActiveItem := -1;
Repaint;
end;
end else begin
if ItemIndex <> -1 then begin
if (ItemIndex <> FActiveItem) then begin
if FActiveItem <> -1 then
{invalidate the old activeItem}
InvalidateItem(FActiveFolder, FActiveItem);
FActiveItem := ItemIndex;
if FActiveItem <> -1 then begin
{invalidate the new active item}
InvalidateItem(FActiveFolder, FActiveItem);
end;
end;
end else if FActiveItem <> -1 then begin
InvalidateItem(FActiveFolder, FActiveItem);
FActiveItem := -1;
end;
if FolderIndex <> -1 then begin
if (FolderIndex <> FHotFolder) then begin
if FHotFolder <> -1 then
{invalidate the old activeItem}
Invalidate;
FHotFolder := FolderIndex;
if FHotFolder <> -1 then begin
{invalidate the new active item}
Invalidate;
end;
end;
end else if FHotFolder <> -1 then begin
Invalidate;
FHotFolder := -1;
end;
end;
if ItemIndex <> - 1 then begin
if nabLastMouseOverItem <> ItemIndex then
DoMouseOverItem(X, Y, ItemIndex);
nabLastMouseOverItem := ItemIndex;
end else
nabLastMouseOverItem := -1;
inherited MouseMove(Shift, X, Y);
end;
{=====}
procedure TVpCustomNavBar.MouseUp(Button : TMouseButton; Shift : TShiftState;
X, Y : Integer);
var
FolderIndex : Integer;
ItemIndex : Integer;
Folder : TVpNavFolder;
Item : TVpNavBtnItem;
FromItem : TVpNavBtnItem;
SourceName : string;
begin
if nabMouseDown then begin
try
nabGetHitTest(X, Y, FolderIndex, ItemIndex);
if (FActiveItem <> -1) and (ItemIndex <> -1) then begin
FSelectedItem := ItemIndex;
InvalidateItem(FActiveFolder, ItemIndex);
if FActiveItem = ItemIndex then
DoItemClick(Button, Shift, ItemIndex);
end;
if nabDragFromItem <> -1 then begin
if nabDropHitTest(X, Y) then begin
{get the old item}
Folder := Folders[nabDragFromFolder];
FromItem := TVpNavBtnItem(Folder.Items[nabDragFromItem]);
{create the new item}
Folder := Folders[nabDragToFolder];
Item := TVpNavBtnItem(Folder.FItems.Insert(nabDragToItem));
Item.Assign(FromItem);
SourceName := FromItem.Name;
FromItem.Free;
Item.Name := SourceName;
nabRecalcDisplayNames;
DoArrange;
end;
nabDragFromFolder := -1;
nabDragFromItem := -1;
end;
if (ItemIndex = -1) then begin
{ Fire the OnFolderClick event. }
DoFolderClick(Button, Shift, FolderIndex);
ActiveFolder := FolderIndex;
end;
finally
Invalidate;
nabMouseDown := False;
end;
end;
inherited MouseUp(Button, Shift, X, Y);
end;
{=====}
procedure TVpCustomNavBar.Notification(AComponent : TComponent;
Operation : TOperation);
begin
inherited Notification(AComponent, Operation);
if Operation = opRemove then begin
if AComponent = FImages then
Images := nil;
end;
end;
{=====}
procedure TVpCustomNavBar.Paint;
var
I : Integer;
J : Integer;
X : Integer;
W : Integer;
H : Integer;
CurPos : Integer;
lOffset : Integer;
BkMode : Integer;
LabelWidth : Integer;
Flags : Integer;
MyRect : TRect;
TR : TRect;
ContainerRect : TRect;
FolderType : TVpFolderType;
BkColor : TColor;
Folder : TVpNavFolder;
Item : TVpNavBtnItem;
DrawBmp : TBitmap;
Text : string;
Buf : array[0..255] of Char;
DrawFolder : Boolean;
BM : TBitmap;
RowStart : Integer;
ILeft : Integer;
IHeight : Integer;
IWidth : integer;
begin
if nabChanging then
Exit;
DrawBmp := TBitMap.Create;
try
DrawBmp.Width := ClientWidth;
DrawBmp.Height := ClientHeight;
DrawBmp.Canvas.Font := Self.Font;
with DrawBmp.Canvas do begin
Pen.Color := FBackgroundColor;
Brush.Color := FBackgroundColor;
MyRect := ClientRect;
DrawFolder := (FolderCount > 0);
if DrawFolder then
TR := nabGetFolderArea(FActiveFolder)
else
TR := ClientRect;
if FBackgroundImage.Empty or (FBackgroundMethod = bmNone) then
Rectangle(TR.Left, TR.Top, TR.Right, TR.Bottom)
else begin
case FBackgroundMethod of
bmNormal :
Draw(TR.Left, TR.Top, FBackgroundImage);
bmStretch :
StretchDraw(TR, FBackgroundImage);
bmTile :
begin
{Tile the background in the default folder}
RowStart := 0;
IHeight := FBackgroundImage.Height;
IWidth := FBackgroundImage.Width;
ILeft := 0;
while (RowStart < ClientRect.Bottom) do begin
while (ILeft < ClientRect.Right) do begin
Draw(TR.Left + ILeft, RowStart, FBackgroundImage);
Inc(ILeft, IWidth);
end;
ILeft := 0;
Inc(RowStart, IHeight)
end;
end;
end;
end;
CurPos := 0;
if FolderCount = 0 then begin
nabScrollUpBtn.Visible := False;
nabScrollDownBtn.Visible := False;
Exit;
end;
{draw the folder buttons at the top}
if DrawFolder then begin
for I := 0 to FActiveFolder do begin
MyRect.Top := CurPos;
MyRect.Bottom := CurPos + FButtonHeight;
Folders[I].lfRect := MyRect;
{Draw the top tabs based on the selected style...}
case FDrawingStyle of
dsDefButton : begin
{Draw regular buttons}
//TODO: TR := DrawButtonFace(DrawBmp.Canvas, MyRect, 1, bsNew, False,
// (I = FHotFolder) and nabMouseDown, False);
end;
dsEtchedButton : begin
{Draw regular etched (Win98 style) buttons}
Brush.Color := clBtnFace;
FillRect(MyRect);
Pen.Color := clBtnShadow;
Brush.Style := bsClear;
Rectangle(MyRect.Left, MyRect.Top, MyRect.Right - 1,
MyRect.Bottom);
Pen.Color := clBtnHighlight;
MoveTo(MyRect.Left + 1, MyRect.Bottom - 2);
LineTo(MyRect.Left + 1, MyRect.Top + 1);
LineTo(MyRect.Right - 2, MyRect.Top + 1);
{ Draw border around control. }
MoveTo(Width - 1, Top);
LineTo(Width - 1, Height - 1);
LineTo(0, Height - 1);
Pen.Color := clWindowFrame;
MoveTo(Width - 1, MyRect.Bottom);
LineTo(1, MyRect.Bottom);
LineTo(1, Height - 1);
TR := MyRect;
end;
dsCoolTab: begin
{Draw cool (Netscape Sidebar style) tabs}
TR := DrawNavTab(DrawBmp.Canvas, {Canvas}
MyRect, {Client Rect}
1, {Bevel Width}
FBackgroundColor, {Tab Color}
I, {Tab Number}
true, {Cool Tabs?}
(I = FHotFolder), {Is Focused}
(I = nabLastMouseOverItem)); {MouseOverItem}
end;
dsStandardTab: begin
{Draw regular old tabs}
TR := DrawNavTab(DrawBmp.Canvas, {Canvas}
MyRect, {Client Rect}
1, {Bevel Width}
FBackgroundColor, {Tab Color}
I, {Tab Number}
false, {Cool Tabs?}
(I = FHotFolder), {Is Focused}
(I = nabLastMouseOverItem)); {MouseOverItem}
end;
end;
StrPLCopy(Buf, Folders[I].lfDisplayName, 255);
Inc(TR.Top);
Flags := DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
if Folders[I].Enabled then begin
DrawText(DrawBmp.Canvas.Handle, Buf, StrLen(Buf), TR, Flags);
if (I = FHotFolder) and not nabMouseDown then begin
case FDrawingStyle of
dsDefButton : begin
{ Regular button style. }
InflateRect(TR,1,1);
inc(TR.Left);
DrawBmp.Canvas.Frame3D(TR, 1,bvRaised);
end;
dsEtchedButton : begin
{ Etched style (Outlook98). }
Pen.Color := clWindowFrame;
MoveTo(TR.Right - 2, TR.Top);
LineTo(TR.Right - 2, TR.Bottom - 1);
LineTo(0, TR.Bottom - 1);
Pen.Color := clBtnShadow;
if I = ActiveFolder then
lOffset := 1
else
lOffset := 2;
MoveTo(TR.Right - 3, TR.Top - 2);
LineTo(TR.Right - 3, TR.Bottom - lOffset);
LineTo(1, TR.Bottom - lOffset);
if I = ActiveFolder then
Pixels[1, TR.Bottom - lOffset] := clBtnHighlight;
end;
end;
end;
end else begin
{use shadow text for inactive folder text}
DrawBmp.Canvas.Font.Color := clHighlightText;
SetBkMode(Canvas.Handle, OPAQUE);
DrawText(DrawBmp.Canvas.Handle, Buf, -1, TR, Flags);
SetBkMode(DrawBmp.Canvas.Handle, TRANSPARENT);
DrawBmp.Canvas.Font.Color := clBtnShadow;
OffsetRect(TR, -2, -1);
DrawText(DrawBmp.Canvas.Handle, Buf, -1, TR, Flags);
DrawBmp.Canvas.Font.Color := Self.Font.Color;
end;
Inc(CurPos, FButtonHeight);
end;
end else begin
if FDrawingStyle = dsEtchedButton then begin
{ Draw border around control. }
Pen.Color := clBtnHighlight;
MoveTo(Width - 1, Top);
LineTo(Width - 1, Height - 1);
LineTo(0, Height - 1);
Pen.Color := clWindowFrame;
MoveTo(0, Height - 1);
LineTo(0, 1);
LineTo(Width - 2, 1);
end;
CurPos := 0;
end;
//TODO:
{ BkMode := GetBkMode(Handle);
BkColor := GetBkColor(Handle);
SetBkColor(Handle, DWord(FBackgroundColor));
SetBkMode(Handle, TRANSPARENT);
}
{ draw the items for the active folder }
Folder := Folders[FActiveFolder];
if Folder.FolderType = ftDefault then
if Folder.ItemCount > 0 then begin
Inc(CurPos, 8);
with nabItemsRect do begin
Top := CurPos;
Left := 0;
Right := ClientWidth;
Bottom := ClientHeight
- (FolderCount - FActiveFolder - 1) * FButtonHeight + 1;
end;
for J := 0 to Folder.ItemCount-1 do
TVpNavBtnItem(Folder.Items[J]).FLabelRect.Bottom :=
nabItemsRect.Bottom + 1;
for J := nabTopItem to Folder.ItemCount-1 do begin
if (FSelectedItem = J) then
DrawBmp.Canvas.Font := FSelectedItemFont
else
DrawBmp.Canvas.Font := FItemFont;
Item := Folder.Items[J];
{ If the caption is empty at designtime then display the item's }
{ name instead }
if (csDesigning in ComponentState) and (Item.Caption = '') then
Text := Item.Name
else
Text := Item.Caption;
if Folder.IconSize = isLarge then begin {large icons}
{ glyph is at the top }
with Item.FIconRect do begin
{ If an image list is assigned then use the image }
{ size. If no image list is assinged then assume }
{ a 32 x 32 image size. }
if Assigned(FImages) then begin
W := FImages.Width + 2;
H := FImages.Height + 2;
end else begin
W := 32;
H := 32;
end;
Top := CurPos;
Bottom := CurPos + H;
Left := (ClientWidth - W) shr 1;
Right := Left + W;
if Top > nabItemsRect.Bottom then
Break;
if FShowButtons then begin
if FActiveItem = J then begin
if nabMouseDown then
Pen.Color := clBlack
else
Pen.Color := clWhite;
MoveTo(Left-1, Bottom+1);
LineTo(Left-1, Top-1);
LineTo(Right+1, Top-1);
if nabMouseDown then
Pen.Color := clWhite
else
Pen.Color := clBlack;
LineTo(Right+1, Bottom+1);
LineTo(Left-1, Bottom+1);
end else begin
Pen.Color := FBackgroundColor;
Brush.Color := FBackgroundColor;
end;
if Assigned(FImages) and
(Item.IconIndex >= 0) and
(Item.IconIndex < FImages.Count) then
FImages.Draw(DrawBmp.Canvas, Item.FIconRect.Left + 2,
Item.FIconRect.Top + 2, Item.IconIndex);
{make the icon's bottom blend into the label's top}
Item.FIconRect.Bottom := Item.FIconRect.Bottom + 4;
end;
end;
Inc(CurPos, H + 4);
{now, draw the text}
with Item.FLabelRect do begin
Top := CurPos;
Bottom := CurPos + (FButtonHeight shl 1) - 7;
Left := 0;
Right := ClientWidth - 1;
Item.liDisplayName := GetLargeIconDisplayName(DrawBmp.Canvas,
Item.FLabelRect, Text);
X := DrawBmp.Canvas.TextWidth(Item.liDisplayName);
Left := (ClientWidth - X) div 2;
if Left < 5 then
Left := 5;
Right := Left + X;
if Right > ClientWidth-5 then
Right := ClientWidth-5;
if Top > nabItemsRect.Bottom then
Break;
end;
StrPLCopy(Buf, Item.liDisplayName, 255);
DrawText(DrawBmp.Canvas.Handle, Buf, Length(Item.liDisplayName),
Item.FLabelRect, DT_CENTER or DT_VCENTER or
DT_WORDBREAK or DT_CALCRECT);
LabelWidth := RectWidth(Item.FLabelRect);
with Item.FLabelRect do begin
Left := (ClientWidth - LabelWidth) div 2;
Right := Left + LabelWidth + 1;
end;
BkMode := SetBkMode(DrawBmp.Canvas.Handle, TRANSPARENT);
Inc(CurPos, DrawText(DrawBmp.Canvas.Handle, Buf,
Length(Item.liDisplayName),
Item.FLabelRect,
DT_CENTER or DT_VCENTER or DT_WORDBREAK));
SetBkMode(DrawBmp.Canvas.Handle, BkMode);
Inc(CurPos, FItemSpacing);
end else begin {small icons}
{glyph is at the left}
with Item.FIconRect do begin
Top := CurPos;
lOffset := (Abs(DrawBmp.Canvas.Font.Height)) div 2;
if lOffset > 8 then
Top := Top + lOffset - 8;
Bottom := Top + 16;
Left := 8;
Right := Left + 16;
if Top > nabItemsRect.Bottom then
Break;
if FShowButtons then begin
if FActiveItem = J then begin
if nabMouseDown then
Pen.Color := clBlack
else
Pen.Color := clWhite;
MoveTo(Left-1, Bottom+1);
LineTo(Left-1, Top-1);
LineTo(Right+1, Top-1);
if nabMouseDown then
Pen.Color := clWhite
else
Pen.Color := clBlack;
LineTo(Right+1, Bottom+1);
LineTo(Left-1, Bottom+1);
Brush.Color := FBackgroundColor;
end else begin
Pen.Color := FBackgroundColor;
Brush.Color := FBackgroundColor;
Rectangle(Item.FIconRect.Left - 1,
Item.FIconRect.Top - 1,
Item.FIconRect.Right + 1,
Item.FIconRect.Bottom + 1);
end;
if Assigned(FImages) then begin
BM := TBitmap.Create;
try
BM.Width := FImages.Width;
BM.Height := FImages.Height;
FImages.Draw(BM.Canvas, 0, 0, Item.IconIndex);
//TODO: DrawBmp.Canvas.BrushCopy(Item.FIconRect, BM,
// Rect(0, 0, BM.Width, BM.Height), BM.Canvas.Pixels[0,
// BM.Height-1]);
finally
BM.Free;
end;
end;
end;
{make the icon's right blend into the label's left}
Item.FIconRect.Right := Item.FIconRect.Right + 3;
end;
{now, draw the text}
with Item.FLabelRect do begin
Top := CurPos;
Bottom := CurPos + (FButtonHeight shl 1) -7;
Left := Item.FIconRect.Right;
X := Self.ClientWidth - Left - 7;
Right := Left + X;
if Top > nabItemsRect.Bottom then
Break;
end;
Item.liDisplayName :=
GetDisplayString(DrawBmp.Canvas, Text, 1,
RectWidth(Item.FLabelRect));
StrPLCopy(Buf, Item.liDisplayName, 255);
DrawText(DrawBmp.Canvas.Handle, Buf, Length(Item.liDisplayName),
Item.FLabelRect, DT_LEFT or DT_VCENTER or DT_CALCRECT);
LabelWidth := RectWidth(Item.FLabelRect);
with Item.FLabelRect do
Right := Left + LabelWidth + 1;
DrawText(DrawBmp.Canvas.Handle, Buf, Length(Item.liDisplayName),
Item.FLabelRect, DT_LEFT or DT_VCENTER);
Inc(CurPos, FItemSpacing);
end;
end;
end;
{now, draw the folder buttons at the bottom}
DrawBmp.Canvas.Font := Self.Font;
SetBkMode(Handle, BkMode);
SetBkColor(Handle, BkColor);
case FDrawingStyle of
{ Regular button style. }
dsDefButton :
CurPos := ClientHeight - FButtonHeight;
{ Etched style (Outlook98). }
dsEtchedButton :
CurPos := ClientHeight - FButtonHeight - 1;
{ Cool Tab }
dsCoolTab:
CurPos := ClientHeight - FButtonHeight;
{ Regular Tab }
dsStandardTab:
CurPos := ClientHeight - FButtonHeight;
end;
for I := FolderCount-1 downto FActiveFolder+1 do begin
MyRect.Top := CurPos;
MyRect.Bottom := CurPos + FButtonHeight;
Folders[I].lfRect := MyRect;
case FDrawingStyle of
dsDefButton : begin
{Regular Old Buttons}
//TODO: TR := DrawButtonFace(DrawBmp.Canvas, MyRect, 1, bsNew, False,
// (I = FHotFolder) and nabMouseDown, False);
end;
dsEtchedButton : begin
{Etched (Outlook98 style) buttons}
Brush.Color := clBtnFace;
FillRect(MyRect);
Pen.Color := clBtnShadow;
Brush.Style := bsClear;
Rectangle(MyRect.Left, MyRect.Top, MyRect.Right - 1,
MyRect.Bottom);
Pen.Color := clBtnHighlight;
MoveTo(MyRect.Left + 1, MyRect.Bottom - 2);
LineTo(MyRect.Left + 1, MyRect.Top + 1);
LineTo(MyRect.Right - 2, MyRect.Top + 1);
Pen.Color := clBtnHighlight;
MoveTo(Width - 1, 0);
LineTo(Width - 1, Height);
TR := MyRect;
end;
dsCoolTab: begin
{Draw cool (Netscape Sidebar style) tabs}
TR := DrawNavTab(DrawBmp.Canvas, {Canvas}
MyRect, {Client Rect}
1, {Bevel Width}
FBackgroundColor, {Tab Color}
I, {Tab Number}
true, {Cool Tabs?}
(I = FHotFolder), {Is Focused}
(I = nabLastMouseOverItem)); {MouseOverItem}
end;
dsStandardTab: begin
{Draw regular old tabs}
TR := DrawNavTab(DrawBmp.Canvas, {Canvas}
MyRect, {Client Rect}
1, {Bevel Width}
FBackgroundColor, {Tab Color}
I, {Tab Number}
false, {Cool Tabs?}
(I = FHotFolder), {Is Focused}
(I = nabLastMouseOverItem)); {MouseOverItem}
end;
end;
Inc(TR.Top);
StrPLCopy(Buf, Folders[I].lfDisplayName, 255);
Flags := DT_CENTER or DT_VCENTER or DT_SINGLELINE or DT_NOPREFIX;
if Folders[I].Enabled then begin
DrawText(DrawBmp.Canvas.Handle, Buf, StrLen(Buf), TR, Flags);
if (I = FHotFolder) and not nabMouseDown then begin
case FDrawingStyle of
dsDefButton : begin
{ Regular button style. }
InflateRect(TR,1,1);
inc(TR.Left);
DrawBmp.Canvas.Frame3D(TR,1,bvRaised);
end;
dsEtchedButton : begin
{ Etched (Outlook98 style). }
Pen.Color := clWindowFrame;
MoveTo(TR.Right - 2, TR.Top);
LineTo(TR.Right - 2, TR.Bottom - 1);
LineTo(0, TR.Bottom - 1);
Pen.Color := clBtnShadow;
MoveTo(TR.Right - 3, TR.Top - 2);
LineTo(TR.Right - 3, TR.Bottom - 2);
LineTo(1, TR.Bottom - 2);
end;
end;
end;
end else begin
{use shadow text for inactive folder text}
DrawBmp.Canvas.Font.Color := clHighlightText;
SetBkMode(Canvas.Handle, OPAQUE);
DrawText(DrawBmp.Canvas.Handle, Buf, -1, TR, Flags);
SetBkMode(DrawBmp.Canvas.Handle, TRANSPARENT);
DrawBmp.Canvas.Font.Color := clBtnShadow;
OffsetRect(TR, -2, -1);
DrawText(DrawBmp.Canvas.Handle, Buf, -1, TR, Flags);
DrawBmp.Canvas.Font.Color := Self.Font.Color;
end;
Dec(CurPos, FButtonHeight);
end;
if not (csDesigning in ComponentState) then begin
{show the top scroll button}
if nabShowScrollUp then begin
nabScrollUpBtn.Top := Folders[FActiveFolder].lfRect.Bottom + 5;
nabScrollUpBtn.Left := ClientWidth - 20;
nabScrollUpBtn.Visible := True;
end else
nabScrollUpBtn.Visible := False;
{show the bottom scroll button}
if nabShowScrollDown then begin
if FActiveFolder = FolderCount-1 then
{there are no folders beyond the active one}
nabScrollDownBtn.Top := ClientHeight -20
else
nabScrollDownBtn.Top := Folders[FActiveFolder+1].lfRect.Top - 20;
nabScrollDownBtn.Left := ClientWidth - 20;
nabScrollDownBtn.Visible := True;
end else
nabScrollDownBtn.Visible := False;
end;
{if we're dragging, show the drag marker}
if (nabDragFromItem <> -1) or nabExternalDrag then begin
if (nabDropY <> -1) then begin
{ Don't draw the drag marker if we're doing external }
{ dragging and the cursor is over an item. }
if nabExternalDrag then
if not nabFolderAccept or nabCursorOverItem then
Exit;
Pen.Color := clBlack;
Brush.Color := clBlack;
MoveTo(5, nabDropY);
LineTo(ClientWidth - 5, nabDropY);
DrawBmp.Canvas.Polygon([ Point(3,nabDropY+4),
Point(7,nabDropY),
Point(3, nabDropY-4)]);
DrawBmp.Canvas.FloodFill(5, nabDropY, clBlack, fsBorder);
DrawBmp.Canvas.Polygon([ Point(ClientWidth-3,nabDropY+4),
Point(ClientWidth-7,nabDropY),
Point(ClientWidth-3,nabDropY-4)]);
DrawBmp.Canvas.FloodFill(ClientWidth-5, nabDropY, clBlack, fsBorder);
end;
end;
end;
finally
Canvas.CopyMode := cmSrcCopy;
Canvas.CopyRect(ClientRect, DrawBmp.Canvas, ClientRect);
DrawBmp.Free;
end;
{For container style folders...}
{Hide the containers for all inactive folders}
for I := 0 to FFolders.Count - 1 do begin
if I <> FActiveFolder then begin
if Folders[i].FolderType = ftContainer then
with Containers[Folders[i].ContainerIndex] do begin
Width := 0;
Height := 0;
Visible := false;
end;
end;
end;
Folder := Folders[FActiveFolder];
TR := nabGetFolderArea(FActiveFolder);
if Folder.FolderType = ftContainer then
with Containers[Folder.ContainerIndex] do begin
{Position and show the folder's container}
Height := TR.Bottom - TR.Top;
Top := TR.Top;
Left := TR.Left;
Width := TR.Right - TR.Left;
Visible := true;
BringToFront;
for I := 0 to ControlCount - 1 do
Controls[i].Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetActiveFolder(Value : Integer);
var
Y : Integer;
YDelta : Integer;
R : TRect;
R2 : TRect;
Buf : array[0..1023] of Char;
AllowChange : Boolean;
begin
if Value <> FActiveFolder then begin
if FolderCount = 0 then
FActiveFolder := -1
else if (Value > -1) and (Value < FolderCount) then begin
{ Fire DoFolderChange only if not dragging. }
if nabDragFromItem = -1 then begin
{ Default for AllowChange is True. }
AllowChange := True;
{ Fire the OnFolderChange event. }
DoFolderChange(Value, AllowChange);
{ If AllowChange is False then bail out. }
if not AllowChange then
Exit;
end;
{animated scroll}
if FActiveFolder > -1 then begin
{play sound}
if FPlaySounds and (FSoundAlias > '') then begin
StrPLCopy(Buf, FSoundAlias, SizeOf(Buf)-1);
{$IFNDEF LCL}
FPlaySounds := PlaySound(@Buf, 0, SND_ASYNC);
{$ENDIF}
end;
if Parent <> nil then begin
{scroll selection}
Canvas.Brush.Color := FBackgroundColor;
R := nabGetFolderArea(FActiveFolder);
R2 := R;
if Value > FActiveFolder then begin
{up}
YDelta := -FScrollDelta;
Inc(R.Bottom, Abs(Value-FActiveFolder)*FButtonHeight);
R2.Top := R2.Bottom+Abs(Value-FActiveFolder)*FButtonHeight;
R2.Bottom := R2.Top;
end else begin
{down}
YDelta := +FScrollDelta;
Dec(R.Top, Abs(Value-FActiveFolder)*FButtonHeight);
R2.Bottom := R2.Top-Abs(Value-FActiveFolder)*FButtonHeight;
R2.Top := R2.Bottom;
end;
Y := RectHeight(R)-FScrollDelta;
while Y > 0 do begin
ScrollWindow(Handle, 0, YDelta, @R, @R);
Dec(Y, FScrollDelta);
{fill scrolled area}
if YDelta > 0 then
Inc(R2.Bottom, FScrollDelta)
else
Dec(R2.Top, FScrollDelta);
Canvas.FillRect(R2);
end;
end;
end;
FActiveFolder := Value;
nabTopItem := 0;
FActiveItem := -1;
FSelectedItem := -1;
Invalidate;
end;
{ Fire the OnFolderChanged event. }
DoFolderChanged(FActiveFolder)
end;
end;
{=====}
procedure TVpCustomNavBar.SetBackgroundColor(Value : TColor);
begin
if Value <> FBackgroundColor then begin
FBackgroundColor := Value;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetBackgroundImage(Value : TBitmap);
begin
if Assigned(Value) then
FBackgroundImage.Assign(Value)
else begin
FBackgroundImage.Free;
FBackgroundImage := TBitmap.Create;
end;
Invalidate;
end;
{=====}
procedure TVpCustomNavBar.SetBackgroundMethod(Value : TVpBackgroundMethod);
begin
if Value <> FBackgroundMethod then begin
FBackgroundMethod := Value;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetBorderStyle(const Value : TBorderStyle);
begin
if Value <> FBorderStyle then begin
FBorderStyle := Value;
RecreateWnd{$IFDEF LCL}(self){$ENDIF};
end;
end;
{=====}
procedure TVpCustomNavBar.SetButtonHeight(Value : Integer);
begin
if Value <> FButtonHeight then begin
{Minimum ButtonHeight for CoolTabs is 17}
if FDrawingStyle = dsCoolTab then begin
if Value < 17 then FButtonHeight := 17
else FButtonHeight := Value;
end else
FButtonHeight := Value;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetDrawingStyle(Value: TVpFolderDrawingStyle);
begin
if Value <> FDrawingStyle then begin
FDrawingStyle := Value;
if FDrawingStyle = dsEtchedButton then
BorderStyle := bsNone
else
BorderStyle := bsSingle;
{Minimum ButtonHeight for CoolTabs is 17}
if (FDrawingStyle = dsCoolTab) and (FButtonHeight < 17) then
FButtonHeight := 17;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetBounds(ALeft, ATop, AWidth, AHeight : Integer);
begin
inherited SetBounds(ALeft, ATop, AWidth, AHeight);
nabRecalcDisplayNames;
end;
{=====}
procedure TVpCustomNavBar.SetImages(Value : TImageList);
begin
if FImages <> nil then
FImages.OnChange := nil;
FImages := Value;
if FImages <> nil then begin
Images.OnChange := nabImagesChanged;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetItemFont(Value : TFont);
begin
if Assigned(Value) then
FItemFont.Assign(Value);
end;
{=====}
procedure TVpCustomNavBar.SetItemSpacing(Value : Word);
begin
if (Value > 0) then begin
FItemSpacing := Value;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.SetSelectedItemFont(Value : TFont);
begin
if Assigned(Value) then
FSelectedItemFont.Assign(Value);
end;
{=====}
procedure TVpCustomNavBar.SetScrollDelta(Value: Integer);
begin
if Value <= 0 then
FScrollDelta := 1
else
FScrollDelta := Value;
end;
{=====}
{$IFDEF LCL}
procedure TVpCustomNavBar.WMEraseBkGnd(var Msg : TLMEraseBkGnd);
{$ELSE}
procedure TVpCustomNavBar.WMEraseBkGnd(var Msg : TWMEraseBkGnd);
{$ENDIF}
begin
Msg.Result := 1; {don't erase background}
end;
{=====}
{$IFNDEF LCL}
procedure TVpCustomNavBar.WMGetDlgCode(var Msg : TWMGetDlgCode);
begin
{tell windows we are a static control to avoid receiving the focus}
Msg.Result := DLGC_STATIC;
end;
{$ENDIF}
{=====}
{$IFDEF LCL}
procedure TVpCustomNavBar.WMNCHitTest(var Msg : TLMNCHitTest);
{$ELSE}
procedure TVpCustomNavBar.WMNCHitTest(var Msg : TWMNCHitTest);
{$ENDIF}
begin
inherited;
nabHitTest.X := Msg.Pos.X;
nabHitTest.Y := Msg.Pos.Y;
end;
{=====}
{$IFNDEF LCL}
procedure TVpCustomNavBar.WMSetCursor(var Msg : TWMSetCursor);
var
I : Integer;
R : TRect;
begin
if csDesigning in ComponentState then begin
if (Msg.HitTest = HTCLIENT) then begin
nabOverButton := False;
nabHitTest := ScreenToClient(nabHitTest);
{check if mouse is over a button}
for I := 0 to FolderCount-1 do begin
R := nabButtonRect(I);
if PtInRect(R, nabHitTest) then begin
nabOverButton := True;
Break;
end;
end;
end;
end;
inherited;
end;
{$ENDIF}
{=====}
{ Overridden DragOver method. }
procedure TVpCustomNavBar.DragOver(Source: TObject;
X, Y: Integer;
State: TDragState;
var Accept: Boolean);
var
ItemIndex : Integer;
FolderIndex : Integer;
begin
{ If State is dsDragLeave then the user has dragged }
{ outside us. Invalidate the component to get rid }
{ of any left-over drawing and exit. }
if State = dsDragLeave then begin
nabExternalDrag := False;
nabFolderAccept := False;
nabItemAccept := False;
nabMouseDown := False;
nabChanging := False;
nabTopItem := 0;
nabDragFromItem := -1;
nabDragFromFolder := -1;
Invalidate;
nabAcceptAny := False;
inherited DragOver(Source, X, Y, State, nabAcceptAny);
Exit;
end;
nabFolderAccept := True;
nabItemAccept := True;
{ Call the user's OnDragOver. }
if Assigned(FOnDragOver) then
FOnDragOver(Self, Source,
X, Y, State, nabFolderAccept, nabItemAccept);
{ Might have to scroll the items in the folder. }
if nabScrollDownBtn.Visible then begin
if Y > nabScrollDownBtn.Top then begin
Inc(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
end;
end;
if nabScrollUpBtn.Visible then begin
if Y < (nabScrollUpBtn.Top + nabScrollUpBtn.Height)then begin
Dec(nabTopItem);
InvalidateRect(Handle, @nabItemsRect, False);
end;
end;
Accept := nabFolderAccept or nabItemAccept;
if nabFolderAccept or nabItemAccept then begin
nabGetHitTest(X, Y, FolderIndex, ItemIndex);
nabDropHitTest(X, Y);
nabExternalDrag := True;
{ Change folder if necessary. }
if (FolderIndex <> -1) and (FolderIndex <> FActiveFolder) then
ActiveFolder := FolderIndex;
if nabItemAccept then
FActiveItem := ItemIndex;
Invalidate;
end;
end;
{=====}
procedure TVpCustomNavBar.DragDrop(Source: TObject; X, Y : Integer);
begin
if Assigned(FOnDragDrop) then
FOnDragDrop(Self, Source, X, Y, FActiveFolder, nabExternalDragItem);
nabExternalDrag := False;
nabFolderAccept := False;
nabItemAccept := False;
nabMouseDown := False;
nabChanging := False;
nabTopItem := 0;
nabDragFromFolder := -1;
Invalidate;
inherited DragDrop(Source, X, Y);
end;
{=====}
function TVpCustomNavBar.GetChildOwner: TComponent;
begin
Result := Self;
end;
end.
Reference in New Issue View Git Blame Copy Permalink