Im looking for a delphi component that looks and functions like the Windows 7 control panel buttons when you "view by category". Anybody know if something like this already exists?
I just created a small component that looks sort of what you want. It is double-buffered, and hence completely flicker-free, and works both with visual themes enabled and disabled.
unit TaskButton; interface uses SysUtils, Forms, Messages, Windows, Graphics, Classes, Controls, UxTheme, ImgList, PNGImage; type TIconSource = (isImageList, isPNGImage); TTaskButtonLinkClickEvent = procedure(Sender: TObject; LinkIndex: integer) of object; TTaskButton = class(TCustomControl) private { Private declarations } FCaption: TCaption; FHeaderRect: TRect; FImageSpacing: integer; FLinks: TStrings; FHeaderHeight: integer; FLinkHeight: integer; FLinkSpacing: integer; FHeaderSpacing: integer; FLinkRects: array of TRect; FPrevMouseHoverIndex: integer; FMouseHoverIndex: integer; FImages: TImageList; FImageIndex: TImageIndex; FIconSource: TIconSource; FImage: TPngImage; FBuffer: TBitmap; FOnLinkClick: TTaskButtonLinkClickEvent; procedure UpdateMetrics; procedure SetCaption(const Caption: TCaption); procedure SetImageSpacing(ImageSpacing: integer); procedure SetLinkSpacing(LinkSpacing: integer); procedure SetHeaderSpacing(HeaderSpacing: integer); procedure SetLinks(Links: TStrings); procedure SetImages(Images: TImageList); procedure SetImageIndex(ImageIndex: TImageIndex); procedure SetIconSource(IconSource: TIconSource); procedure SetImage(Image: TPngImage); procedure SwapBuffers; function ImageWidth: integer; function ImageHeight: integer; procedure SetNonThemedHeaderFont; procedure SetNonThemedLinkFont(Hovering: boolean = false); protected { Protected declarations } procedure Paint; override; procedure WndProc(var Message: TMessage); override; procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseMove(Shift: TShiftState; X: Integer; Y: Integer); override; procedure MouseUp(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; public { Public declarations } constructor Create(AOwner: TComponent); override; destructor Destroy; override; published { Published declarations } property Caption: TCaption read FCaption write SetCaption; property Links: TStrings read FLinks write SetLinks; property ImageSpacing: integer read FImageSpacing write SetImageSpacing default 16; property HeaderSpacing: integer read FHeaderSpacing write SetHeaderSpacing default 2; property LinkSpacing: integer read FLinkSpacing write SetLinkSpacing default 2; property Images: TImageList read FImages write SetImages; property ImageIndex: TImageIndex read FImageIndex write SetImageIndex; property Image: TPngImage read FImage write SetImage; property IconSource: TIconSource read FIconSource write SetIconSource default isPNGImage; property OnLinkClick: TTaskButtonLinkClickEvent read FOnLinkClick write FOnLinkClick; end; procedure Register; implementation uses Math; procedure Register; begin RegisterComponents('Rejbrand 2009', [TTaskButton]); end; function IsIntInInterval(x, xmin, xmax: integer): boolean; inline; begin IsIntInInterval := (xmin <= x) and (x <= xmax); end; function PointInRect(const Point: TPoint; const Rect: TRect): boolean; inline; begin PointInRect := IsIntInInterval(Point.X, Rect.Left, Rect.Right) and IsIntInInterval(Point.Y, Rect.Top, Rect.Bottom); end; { TTaskButton } constructor TTaskButton.Create(AOwner: TComponent); begin inherited; InitThemeLibrary; FBuffer := TBitmap.Create; FLinks := TStringList.Create; FImage := TPngImage.Create; FImageSpacing := 16; FHeaderSpacing := 2; FLinkSpacing := 2; FPrevMouseHoverIndex := -1; FMouseHoverIndex := -1; FIconSource := isPNGImage; end; destructor TTaskButton.Destroy; begin FLinkRects := nil; FImage.Free; FLinks.Free; FBuffer.Free; inherited; end; function TTaskButton.ImageHeight: integer; begin result := 0; case FIconSource of isImageList: if Assigned(FImages) then result := FImages.Height; isPNGImage: if Assigned(FImage) then result := FImage.Height; end; end; function TTaskButton.ImageWidth: integer; begin result := 0; case FIconSource of isImageList: if Assigned(FImages) then result := FImages.Width; isPNGImage: if Assigned(FImage) then result := FImage.Width; end; end; procedure TTaskButton.MouseDown(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; Paint; end; procedure TTaskButton.MouseMove(Shift: TShiftState; X, Y: Integer); var i: Integer; begin inherited; FMouseHoverIndex := -1; for i := 0 to high(FLinkRects) do if PointInRect(point(X, Y), FLinkRects[i]) then begin FMouseHoverIndex := i; break; end; if FMouseHoverIndex <> FPrevMouseHoverIndex then begin Cursor := IfThen(FMouseHoverIndex <> -1, crHandPoint, crDefault); Paint; end; FPrevMouseHoverIndex := FMouseHoverIndex; end; procedure TTaskButton.MouseUp(Button: TMouseButton; Shift: TShiftState; X, Y: Integer); begin inherited; Paint; if (FMouseHoverIndex <> -1) and Assigned(FOnLinkClick) then FOnLinkClick(Self, FMouseHoverIndex); end; procedure TTaskButton.Paint; var theme: HTHEME; i: Integer; pnt: TPoint; r: PRect; begin inherited; if FLinks.Count <> length(FLinkRects) then UpdateMetrics; FBuffer.Canvas.Brush.Color := Color; FBuffer.Canvas.FillRect(ClientRect); if GetCursorPos(pnt) then if PointInRect(Self.ScreenToClient(pnt), ClientRect) then begin if UxTheme.UseThemes then begin theme := OpenThemeData(Handle, 'BUTTON'); if theme <> 0 then try DrawThemeBackground(theme, FBuffer.Canvas.Handle, BP_COMMANDLINK, CMDLS_HOT, ClientRect, nil); finally CloseThemeData(theme); end; end else begin New(r); try r^ := ClientRect; DrawEdge(FBuffer.Canvas.Handle, r^, EDGE_RAISED, BF_RECT); finally Dispose(r); end; end; end; case FIconSource of isImageList: if Assigned(FImages) then FImages.Draw(FBuffer.Canvas, 14, 16, FImageIndex); isPNGImage: if Assigned(FImage) then FBuffer.Canvas.Draw(14, 16, FImage); end; if UxTheme.UseThemes then begin theme := OpenThemeData(Handle, 'CONTROLPANEL'); if theme <> 0 then try DrawThemeText(theme, FBuffer.Canvas.Handle, CPANEL_SECTIONTITLELINK, CPSTL_NORMAL, PChar(Caption), length(Caption), DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE, 0, FHeaderRect); for i := 0 to FLinks.Count - 1 do DrawThemeText(theme, FBuffer.Canvas.Handle, CPANEL_CONTENTLINK, IfThen(FMouseHoverIndex = i, IfThen(csLButtonDown in ControlState, CPCL_PRESSED, CPCL_HOT), CPCL_NORMAL), PChar(FLinks[i]), length(FLinks[i]), DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE, 0, FLinkRects[i] ); finally CloseThemeData(theme); end; end else begin SetNonThemedHeaderFont; DrawText(FBuffer.Canvas.Handle, PChar(Caption), -1, FHeaderRect, DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE); for i := 0 to FLinks.Count - 1 do begin SetNonThemedLinkFont(FMouseHoverIndex = i); DrawText(FBuffer.Canvas.Handle, PChar(FLinks[i]), -1, FLinkRects[i], DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE); end; end; SwapBuffers; end; procedure TTaskButton.SetCaption(const Caption: TCaption); begin if not SameStr(FCaption, Caption) then begin FCaption := Caption; UpdateMetrics; Paint; end; end; procedure TTaskButton.SetHeaderSpacing(HeaderSpacing: integer); begin if FHeaderSpacing <> HeaderSpacing then begin FHeaderSpacing := HeaderSpacing; UpdateMetrics; Paint; end; end; procedure TTaskButton.SetIconSource(IconSource: TIconSource); begin if FIconSource <> IconSource then begin FIconSource := IconSource; UpdateMetrics; Paint; end; end; procedure TTaskButton.SetImage(Image: TPngImage); begin FImage.Assign(Image); UpdateMetrics; Paint; end; procedure TTaskButton.SetImageIndex(ImageIndex: TImageIndex); begin if FImageIndex <> ImageIndex then begin FImageIndex := ImageIndex; UpdateMetrics; Paint; end; end; procedure TTaskButton.SetImages(Images: TImageList); begin FImages := Images; UpdateMetrics; Paint; end; procedure TTaskButton.SetImageSpacing(ImageSpacing: integer); begin if FImageSpacing <> ImageSpacing then begin FImageSpacing := ImageSpacing; UpdateMetrics; Paint; end; end; procedure TTaskButton.SetLinks(Links: TStrings); begin FLinks.Assign(Links); UpdateMetrics; Paint; end; procedure TTaskButton.SetLinkSpacing(LinkSpacing: integer); begin if FLinkSpacing <> LinkSpacing then begin FLinkSpacing := LinkSpacing; UpdateMetrics; Paint; end; end; procedure TTaskButton.SwapBuffers; begin BitBlt(Canvas.Handle, 0, 0, Width, Height, FBuffer.Canvas.Handle, 0, 0, SRCCOPY); end; procedure TTaskButton.WndProc(var Message: TMessage); begin inherited; case Message.Msg of WM_SIZE: UpdateMetrics; CM_MOUSEENTER: Paint; CM_MOUSELEAVE: Paint; WM_ERASEBKGND: Message.Result := 1; end; end; procedure TTaskButton.UpdateMetrics; var theme: HTHEME; cr, r: TRect; i, y: Integer; begin FBuffer.SetSize(Width, Height); SetLength(FLinkRects, FLinks.Count); if UxTheme.UseThemes then begin theme := OpenThemeData(Handle, 'CONTROLPANEL'); if theme <> 0 then try with cr do begin Top := 10; Left := ImageWidth + FImageSpacing; Right := Width - 4; Bottom := Self.Height; end; GetThemeTextExtent(theme, FBuffer.Canvas.Handle, CPANEL_SECTIONTITLELINK, CPSTL_NORMAL, PChar(Caption), -1, DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE, @cr, r); FHeaderHeight := r.Bottom - r.Top; with FHeaderRect do begin Top := 10; Left := 14 + ImageWidth + FImageSpacing; Right := Width - 4; Bottom := Top + FHeaderHeight; end; with cr do begin Top := 4; Left := 14 + ImageWidth + FImageSpacing; Right := Width - 4; Bottom := Self.Height; end; y := FHeaderRect.Bottom + FHeaderSpacing; for i := 0 to high(FLinkRects) do begin GetThemeTextExtent(theme, FBuffer.Canvas.Handle, CPANEL_CONTENTLINK, CPCL_NORMAL, PChar(FLinks[i]), -1, DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE, @cr, r); FLinkHeight := r.Bottom - r.Top; FLinkRects[i].Left := FHeaderRect.Left; FLinkRects[i].Top := y; FLinkRects[i].Right := FLinkRects[i].Left + r.Right - r.Left; FLinkRects[i].Bottom := FLinkRects[i].Top + FLinkHeight + FLinkSpacing; inc(y, FLinkHeight + FLinkSpacing); end; finally CloseThemeData(theme); end; end else begin SetNonThemedHeaderFont; FHeaderHeight := FBuffer.Canvas.TextHeight(FCaption); with FHeaderRect do begin Top := 10; Left := 14 + ImageWidth + FImageSpacing; Right := Width - 4; Bottom := Top + FHeaderHeight; end; SetNonThemedLinkFont; y := FHeaderRect.Bottom + FHeaderSpacing; for i := 0 to high(FLinkRects) do with FBuffer.Canvas.TextExtent(FLinks[i]) do begin FLinkHeight := cy; FLinkRects[i].Left := FHeaderRect.Left; FLinkRects[i].Top := y; FLinkRects[i].Right := FLinkRects[i].Left + cx; FLinkRects[i].Bottom := FLinkRects[i].Top + FLinkHeight + FLinkSpacing; inc(y, FLinkHeight + FLinkSpacing); end; end; end; procedure TTaskButton.SetNonThemedHeaderFont; begin with FBuffer.Canvas.Font do begin Color := clNavy; Style := []; Size := 14; end; end; procedure TTaskButton.SetNonThemedLinkFont(Hovering: boolean = false); begin with FBuffer.Canvas.Font do begin Color := clNavy; if Hovering then Style := [fsUnderline] else Style := []; Size := 10; end; end; initialization // Override Delphi's ugly hand cursor with the nice Windows hand cursor Screen.Cursors[crHandPoint] := LoadCursor(0, IDC_HAND); end. Screenshots:
If I get time over I will add a keyboard interface to it.
I guess this is a customized ListView with activated Tile View.
See "About List-View Controls" on MSDN.
That is part of the Windows shell. It looks like these components wrap the windows shell functionality.
来源：https://stackoverflow.com/questions/3986067/delphi-windows-7-control-panel-component