1. Inicio
  2. Pregunta y respuesta
  3. Delphi componente del panel de control de Windows 7

Delphi componente del panel de control de Windows 7

2010-10-21 34 views
6

Estoy buscando un componente delphi que se ve y funciona como los botones del panel de control de Windows 7 cuando "ver por categoría". ¿Alguien sabe si algo como esto ya existe?Delphi componente del panel de control de Windows 7

alt text

Fuente

2010-10-21 Hardy Le Roux

+0

Quiero crear un menú en mi propio software que funcione como los enlaces del panel de control –

+0

¿Me pueden ayudar con [este problema] [1]? Tenía fondo negro y letras chinas. [1]: http://stackoverflow.com/questions/28661712/problems-with-ttaskbutton-control-panel-component-in-lazarus-delphi –

Respuesta

17

Acabo de crear un pequeño componente que se ve como que desea. Tiene doble amortiguación, y por lo tanto está completamente libre de parpadeos, y funciona tanto con temas visuales habilitados como deshabilitados.

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.

Imágenes:

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

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

si me da tiempo a lo largo Voy a añadir una interfaz de teclado a la misma.

Fuente

2010-10-21 20:00:48

+0

¡Exactamente lo que necesitaba! Gracias. –

+1

@Andreas: ¡Buen trabajo! – splash

+0

@splash: ¡Gracias! –

0

que forma parte de la shell de Windows. Parece que these components envuelve la funcionalidad del shell de Windows.

Fuente

2010-10-21 12:03:42

+0

he descargado las versiones parciales de componentes de software JAM pero no proporcionaron la funcionalidad que necesito –

1

Supongo que esta es una lista personalizada ListView con activado Tile View.

Ver "About List-View Controls" en MSDN.

Fuente

2010-10-21 12:11:49 splash

+0

Tienes razón. Parece una lista vista en la vista de mosaico, ni siquiera lo había notado antes. –

Cuestiones relacionadas

 Cuestiones relacionadas