DelphiWindows7控制面板组件

我正在寻找一个delphi组件，它的外观和功能与“按类别查看”时的Windows7控制面板按钮类似。有人知道这样的事情是否已经存在吗

---

这是Windows外壳的一部分。它看起来像是包装windows shell功能。

我想这是一个自定义的列表视图，带有激活的平铺视图

---

请参见MSDN上的内容。

我刚刚创建了一个小组件，看起来有点像您想要的。它是双缓冲的，因此完全不闪烁，并且在启用和禁用视觉主题的情况下都可以工作

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.

单元任务按钮；
接口
使用
SysUtils、窗体、消息、窗口、图形、类、控件、主题、，
英语，英语；
类型
TIconSource=（isImageList，isPNGImage）；
TTaskButtonLinkClickEvent=对象的过程（发送方：ToObject；链接索引：integer）；
TTaskButton=类（TCustomControl）
私有的
{私有声明}
FCaption:TCaption；
标题：TRect；
FImageSpacing：整数；
燧石：尖晶石；
FHeaderHeight：整数；
FLinkHeight：整数；
FLinkSpacing：整数；
fheaderspace：整数；
燧石：树突的阵列；
FPrevMouseHoverIndex：整数；
FMO索引：整数；
图像：TImageList；
FImageIndex:TImageIndex；
FIconSource:TIconSource；
FImage:TPngImage；
FBuffer:TBitmap；
FOnLinkClick:TTaskButtonLinkClickEvent；
程序更新计量学；
过程SetCaption（const Caption:tcoption）；
程序SetImageSpacing（ImageSpacing:整数）；
程序SetLinkSpacing（LinkSpacing:整数）；
程序设置HeaderSpacing（HeaderSpacing:整数）；
程序设置链接（链接：TStrings）；
程序设置图像（图像：TImageList）；
程序SetImageIndex（ImageIndex:TImageIndex）；
程序SetIconSource（IconSource:TIconSource）；
程序设置图像（图像：TPngImage）；
程序交换缓冲器；
函数ImageWidth：整数；
函数ImageHeight:整数；
程序设置非主题标题；
过程SetNonThemedLinkFont（悬停：boolean=false）；
受保护的
{受保护的声明}
程序漆；推翻
程序WndProc（变量消息：TMessage）；推翻
过程鼠标向下移动（按钮：TMouseButton；Shift:tShift状态；X:整数；Y:整数）；推翻
过程MouseMove（Shift:tshift状态；X:Integer；Y:Integer）；推翻
过程鼠标（按钮：TMouseButton；Shift:tShift状态；X:整数；Y:整数）；推翻
公众的
{公开声明}
构造函数创建（AOwner:TComponent）；推翻
毁灭者毁灭；推翻
出版
{已发布声明}
属性标题：tcoption read FCaption on write SetCaption；
属性链接：TStrings读FLinks写SetLinks；
属性ImageSpacing：整数读取FImageSpacing写入设置ImageSpacing默认值16；
属性HeaderSpacing：整数读取FHeaderSpacing写入SetHeaderSpacing默认值2；
属性LinkSpacing：整数读取FLinkSpacing写入SetLinkSpacing默认值2；
属性图像：TImageList读取FImages写入SetImages；
属性ImageIndex:TImageIndex读取FImageIndex写入SetImageIndex；
属性映像：TPngImage read FImage write SetImage；
属性IconSource:TIconSource read FIconSource write SetIconSource默认isPNGImage；
属性OnLinkClick:TTaskButtonLinkClickEvent读取FOnLinkClick写入FOnLinkClick；
结束；
程序登记册；
实施
使用数学；
程序登记册；
开始
注册表组件（'Rejbrand 2009'，[TTaskButton]）；
结束；
函数IsIntInInterval（x，xmin，xmax:integer）：布尔型；内联；
开始
IsIntInInterval:=（xmin我下载了JAM软件组件演示，但它们没有提供我需要的功能。我想在我自己的软件中创建一个功能类似于控制面板链接的菜单扫描您帮助我解决[此问题][1]？我有黑色背景和中文字母。[1]：你是对的。它看起来确实像平铺视图中的listView，我以前甚至没有注意到它。这正是我所需要的！谢谢。我在哪里可以获得PNGImage？看起来有许可问题？如果我没记错的话，PNGImage是在Delphi 2009中添加的。你运行的Delphi版本是什么？我找到了Gustavo的PNGImage 1.56。Gustavo的主要PNG对象Is命名为TPngObject，CodeGear的类在delphi 2009中命名为TPngImage。我尝试将您的代码改为使用PngObject，但在安装您的组件后，它仍然无法在delphi 7中工作。如果您能提供任何帮助，我将不胜感激！我不知道
TPngObject
如何工作，但它可能会工作（这门课还有什么用？：）。此外，主题化支持，特别是UxTheme单元，在Delphi 7中不存在。但这只是一个小问题，因为它只包含Windows API中函数的签名。您可以在不使用此单元的情况下使用这些函数。如果您希望应用程序与旧版本的Windows（如XP）兼容，您应该通过
LoadLibrary
和
GetProcAddress
调用这些函数。这是标准的过程，因此应该有很多网站在