1. Zuhause
  2. Frage und Antwort
  3. Delphi Windows 7 Bedienfeld Komponente

Delphi Windows 7 Bedienfeld Komponente

2010-10-21 10 views
6

Ich bin auf der Suche nach einer Delphi-Komponente, die aussieht und funktioniert wie die Windows 7 Systemsteuerung Schaltflächen, wenn Sie "nach Kategorie anzeigen". Weiß jemand, ob sowas schon existiert?Delphi Windows 7 Bedienfeld Komponente

alt text

Quelle

2010-10-21 Hardy Le Roux

+0

Ich möchte ein Menü in meiner eigenen Software erstellen, die wie die Bedienfeldverknüpfungen funktioniert –

+0

Können Sie mir mit [diesem Problem] [1] helfen? Ich hatte schwarzen Hintergrund und chinesische Buchstaben. [1]: http://stackoverflow.com/questions/28661712/problems-with-ttaskbutton-control-panel-component-in-lazarus-delphi –

Antwort

17

Ich habe gerade eine kleine Komponente erstellt, die aussieht, was Sie wollen. Es ist doppelt gepuffert und daher vollständig flimmerfrei und funktioniert sowohl mit aktivierten als auch mit deaktivierten visuellen Themen.

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:

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

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

Wenn ich Zeit, über ich eine Tastatur-Schnittstelle, um es hinzuzufügen.

Quelle

2010-10-21 20:00:48

+0

Genau das, was ich brauchte! Vielen Dank. –

+1

@Andreas: Gute Arbeit! – splash

+0

@splash: Danke! –

0

Das ist Teil der Windows-Shell. Es sieht aus wie these components wrap die Windows-Shell-Funktionalität.

Quelle

2010-10-21 12:03:42

+0

ich die JAM Software-Komponente Demos heruntergeladen, aber sie bieten nicht die Funktionalität, die ich brauche. –

1

Ich denke, dies ist eine benutzerdefinierte ListView mit aktivierten Tile View.

Siehe "About List-View Controls" unter MSDN.

Quelle

2010-10-21 12:11:49 splash

+0

Sie haben Recht. Es sieht wie eine ListView in der Kachelansicht aus, ich habe es vorher nicht einmal bemerkt. –

 Verwandte Themen

  • Keine verwandten Themen^_^