Delphi windows 7控制面板组件

分类：Delphi作者：佚名
我在寻找“按类别查看”时看起来和功能类似于 Windows 7控制面板按钮的delphi组件.有人知道这样的事情是否已经存在？

解决方法

我刚刚创建了一个看起来像你想要的小组件.它是双缓冲的,因此完全没有闪烁,并且可以启用和禁用视觉主题. 
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,FImage);
  end;

  if UxTheme.UseThemes then
  begin

    theme := OpenThemeData(Handle,'CONTROLPANEL');

    if theme <> 0 then
      try

        DrawThemeText(theme,CPANEL_SECTIONTITLELINK,CPSTL_NORMAL,PChar(Caption),length(Caption),DT_LEFT or DT_END_ELLIPSIS or DT_TOP or DT_SINGLELINE,FHeaderRect);

        for i := 0 to FLinks.Count - 1 do
          DrawThemeText(theme,CPANEL_CONTENTLINK,IfThen(FMouseHoverIndex = i,IfThen(csLButtonDown in ControlState,CPCL_PRESSED,CPCL_HOT),CPCL_NORMAL),PChar(FLinks[i]),length(FLinks[i]),FLinkRects[i]
                       );

      finally
        CloseThemeData(theme);
      end;

  end
  else
  begin

    SetNonThemedHeaderFont;
    DrawText(FBuffer.Canvas.Handle,-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,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,Width,Height,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,@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,CPCL_NORMAL,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.

截图：

Image of TTaskButton http://privat.rejbrand.se/TTaskButton.png

Image of TTaskButton (unthemed) http://privat.rejbrand.se/TTaskButtonUnthemed.png

如果我有时间,我会添加一个键盘接口.

版权声明：本文内容由互联网用户自发贡献，该文观点与技术仅代表作者本人。本站仅提供信息存储空间服务，不拥有所有权，不承担相关法律责任。如发现本站有涉嫌侵权/违法违规的内容， 请发送邮件至 dio@foxmail.com 举报，一经查实，本站将立刻删除。

相关推荐

Delphi API HOOK完全说明(存在错误的原文，含修正)
 从网上看到《Delphi API HOOK完全说明》这篇文章，基本上都是大家转来转去，原文出处我已经找不到了。这篇文章写的很不错，但最后部分“PermuteFunction 的终极版本”描述的不太清楚，完全按照该文章代码执行，是不行的。可能是作者故意这样做的？本文最后提供修正后的下载地址。原文如下：一、关于API Hook1.什么是API Hook不知道大家是否还记得，在DO
Delphi API HOOK完全说明(修正及说明)
  从网上看到《Delphi API HOOK完全说明》这篇文章，基本上都是大家转来转去，原文出处我已经找不到了。 这篇文章写的很不错，但最后部分“PermuteFunction 的终极版本”描述的不太清楚，完全按照该文章代码执行，是不行的。需要修改mess.pas中代码才行。其实文中提到的一个结构，代码中并没有使用typePIMAGE_IMPORT_DESCRIPTOR = ^IMA
ffmpeg 部分api delphi 版
ffmpeg 是一套强大的开源的多媒体库 一般都是用 c/c++ 调用， 抽空研究了一下该库的最新版 ，把部分api 翻译成了dephi版的 记录一下 地址 ffmpegvcl.zip
寄存器备忘
32位CPU所含有的寄存器有：4个数据寄存器(EAX、EBX、ECX和EDX)2个变址和指针寄存器(ESI和EDI) 2个指针寄存器(ESP和EBP)6个段寄存器(ES、CS、SS、DS、FS和GS)
键位码
指令整理
1 mov dst, src dst是目的操作数，src是源操作数，指令实现的功能是：将源操作数送到目的操作数中，即：(dst) &lt;--(src) 1.dst和src类型必须匹配，即必须同为字节
delphi中ShellExecute使用详解
有三个API函数可以运行可执行文件WinExec、ShellExecute和CreateProcess。 1.CreateProcess因为使用复杂，比较少用。 2.WinExec主要运行EXE文件。如：WinExec('Notepad.exe Readme.txt', SW_SHOW); 3.ShellExecute不仅可以运行EXE文件，也可以运行已经关联的文件。 首先必须引用shellapi
API函数MoveFileEx使用详解(delphi)
API原型: Declare Function MoveFileEx& Lib "kernel32" Alias "MoveFileExA" (ByVal lpExistingFileName As String, ByVal lpNewFileName As String, ByVal dwFlags As Long) 参数 类型及说明 lpExistingFileName String，欲移
delphi控件安装与删除
附带通用控件安装方法： ---------- 基本安装 1、对于单个控件，Componet-->install component..-->PAS或DCU文件-->install; 2、对于带*.dpk文件的控件包，File-->Open(下拉列表框中选*.dpk)-->install即可； 3、对于带*.bpl文件的控件包，Install Packages-->Add-->bpl文件名即可； 4
Delphi 怎样 把TParams 或 record写到流里面
type   TRec=Record     msg:string;     pic:TMemoryStream; end; procedure TForm2.BitBtn1Click(Sender: TObject); var   ms:TMemoryStream;   Rec1,Rec2:TRec;   cc:tmemorystream;   jpg:TJPEGImage; begin   R
一个用delphi写的整合汇编与api的简单的窗口程序
program Project1; { Types and Structures Definition } type   WNDCLASSEX = packed record     cbSize: LongWord;     style: LongWord;     lpfnWndProc: Pointer;     cbClsExtra: Integer;     cbWndExtra: In
用Delphi模拟键盘输入
   在Windows大行其道的今天，windows界面程序受到广大用户的欢迎。对这些程序的操作不外乎两种，键盘输入控制和鼠标输入控制。有时，对于繁杂 的，或重复性的操作，我们能否通过编制程序来代替手工输入，而用程序来模拟键盘及鼠标的输入呢？答案是肯定的。这主要是通过两个API函数来实现的。 　　 　　下面以Delphi为例来介绍一下如何实现这两个功能。模拟键盘我们用Keybd_event这个ap
Delphi 中的 procedure of object
delphi中经常见到以下两种定义 Type TMouseProc = procedure (X,Y:integer); TMouseEvent = procedure (X,Y:integer) of Object; 两者样子差不多但实际意义却不一样, TMouseProc只是单一的函数指针类型; TMouseEvent是对象的函数指针,也就是对象/类的函数/方法 区
delphi创建具有托盘的服务程序service
Windows 2000/XP和2003等支持一种叫做"服务程序"的东西.程序作为服务启动有以下几个好处:     (1)不用登陆进系统即可运行.     (2)具有SYSTEM特权.所以你在进程管理器里面是无法结束它的.     笔者在2003年为一公司开发机顶盒项目的时候,曾经写过课件上传和媒体服务,下面就介绍一下如何用Delphi7创建一个Service程序.     运行Delphi7,选
delphi服务程序(service)的调试方法
方法一： 1.调试delphi 写的服务程序，有这么一个办法。原来每次都是用attach to process方法，很麻烦。并且按照服务线程的执行线路，可能会停不到想要的断点。笨办法是，在procedure TsvcFrm.ServiceExecute(Sender: TService);中想要下断的语句前加个人定胜天的sleep(20000)，但实际上这种办法是主观臆测的。可行，没问题。记得大学
Delphi For iOS开发指南(17):让应用程序禁止竖屏(也就是只显示横屏)
Delphi For iOS开发指南(17):让应用程序禁止竖屏(也就是只显示横屏)     最近好多人问，怎么样让Delphi For iOS开发的应用程序禁止竖屏，也就是想让它一直横屏显示，横屏是好，一行可以放好几个控件，表格的话也可以多显示几列，看起来方便。 只要一句代码就可以让Delphi For iOS开发的应用程序禁止竖屏，如下： Application.FormFactor.Orie
一个比较完整的Inno Setup 安装脚本
一个比较完整的Inno Setup 安装脚本，增加了对ini文件设置的功能，一个安装包常用的功能都具备了。 [Setup] ; 注: AppId的值为单独标识该应用程序。 ; 不要为其他安装程序使用相同的AppId值。 ; (生成新的GUID，点击 工具|在IDE中生成GUID。) AppId={{A9861883-31C5-4324-BD9A-DC3271EEB675} ;程序名 AppName
Delphi6-xe5 中的MD5实现方法
在Delphi自带的Indy控件中其实是提供了MD2,MD4,MD5对象的，我们可以直接使用它们来完成MD5的签名算法。而不需要再去找其它的DLL或是Pas了。 在Uses单元中引用 IdHashMessageDigest,IdGlobal, IdHash 单元，再写如下代码即可以达到MD5的实现。 示例代码 procedure TForm1.Button1Click(Sender: TObjec
Delphi 7下最小化到系统托盘
在Delphi 7下要制作系统托盘，只能制作一个比较简单的系统托盘，因为ShellAPI文件定义的TNotifyIconData结构体是比较早的版本。定义如下： 1 2 3 4 5 6 7 8 9 _NOTIFYICONDATAA = record    cbSize: DWORD;    Wnd: HWND;    uID: UINT;    uFlags: UINT;    uCallback
Delphi中的Type
声明： 1. type Name = Existing type; 2. type Name = type Existing type; 3. type Name = (EnumValue1 [=value], EnumValue2 [=value] ...); 4. type Name = Expression1..Expression2; 5. type Name = ^Existing ty
pythonJavaScriptjavaHTMLPHPreactjsC#AndroidCSSNode.jssqlrpython-3.xMysqLjQueryc++pandasFlutterangularIOSdjangolinuxswifttypescript路由器JSON路由器设置无线路由器h3c华三华三路由器设置华三路由器电脑软件教程arraysdocker软件图文教程Cvue.jslaravelspring-boot