Dev Faq
6
votes

Composant du panneau de commande Delphi Windows 7

im Recherche d'un composant Delphi qui ressemble et fonctionne comme les boutons du panneau de commande Windows 7 lorsque vous "View par catégorie". Tout le monde savait si quelque chose comme ça existe déjà?

text alt

2 commentaires

Je souhaite créer un menu dans mon propre logiciel qui fonctionne comme les liens du panneau de commande

Pouvez-vous m'aider avec [ce problème] [1]? J'ai eu des antécédents noirs et des lettres chinoises. [1]: Stackoverflow.com/Questtions/28661712/...

3 Réponses :

0
votes

qui fait partie de la coque Windows. Il ressemble à Ces composants enveloppent la fonctionnalité de Shell Windows.

1 commentaires

J'ai téléchargé les démos de la confiture du logiciel de la confiture, mais ils n'ont pas fourni la fonctionnalité dont j'ai besoin.

1
votes

Je suppose que c'est une liste personnalisée ListView avec la vue de carrelage activée .

voir "" À propos de la vue de la liste Contrôles " sur msdn .

1 commentaires

Vous avez raison. Il ressemble à une liste de liste de la vue en carreaux, je ne l'ai même pas remarqué auparavant.

17
votes

Je viens de créer un petit composant qui a l'air de savoir ce que vous voulez. Il est double tamponné et donc complètement sans scintillement, et fonctionne à la fois avec des thèmes visuels activés et désactivés. 

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.

11 commentaires

Exactement ce dont j'avais besoin! Merci.

Où puis-je obtenir pngimage? On dirait qu'il y a un problème de licence?

Si je me souviens bien, PNGIMAGE a été ajouté à Delphi 2009. Quelle version de Delphi utilisez-vous?

J'ai trouvé pngimage 1.56 de Gustavo. Le principal objet PNG de Gustavo est nommé TPngObject et CodeGear's Class est nommé Tpngimage à Delphi 2009. J'ai essayé de changer votre code pour utiliser PngObject à la place, mais après avoir installé votre composant, il ne fonctionne toujours pas dans Delphi 7. Toute aide serait grandement appréciée!

Je n'ai aucune idée de la façon dont tpngobject fonctionne, mais cela devrait probablement fonctionner (quoi d'autre serait la classe? :)). En outre, le support sur le thème, en particulier, l'unité Uxtheme n'existait pas dans Delphi 7. Mais ce n'est qu'un problème mineur, car il ne contient que les signatures des fonctions dans Windows API. Vous pouvez utiliser ces fonctions sans cette unité. Si vous souhaitez que votre application soit compatible avec les versions plus anciennes de Windows (telles que XP), vous devez appeler ces fonctions via loadlibrary et getProcAddress . Il s'agit de procédures standard. Il devrait donc y avoir beaucoup de sites en expliquant cela dans un

Je sais que c'est une vieille réponse - mais j'ai un problème lors de la portion de ce code à Delphi Xe2 - l'en-tête ne dessine pas - tout le reste! Des idées ?

@mmmm Seulement 10 ans plus tard plus tard: le coupable est mauvais avec . Soit dissoudre toutes les utilisations de avec (au moins pour trect s) ou remplacer largeur avec auto.width à l'intérieur d'eux .

FWIW: J'ai remplacé Timagelist avec Tdagimagelist . Ensuite, même les cximagelistes de Devex travaillent. ;-)

@Andreasrejbrand Avez-vous une version mise à jour de ce composant?

@ULIGERHARDT: Non, je viens de l'écrire pour ce q et je ne l'ai jamais utilisé moi-même. Quelque chose en particulier vous souhaitez changer ou corriger?

Non, je viens de tomber dessus et je me sentais obligé de jouer avec ça. ;-) Je ne voulais tout simplement pas manquer d'améliorations potentielles. J'aime comment tu vomis toujours ces petits composants.

Articles qui pourrait vous intéresser :

Système d'exploitation non pris en charge pour MySQL Workbench - Windows 7
NodeJS pour Windows 7
Comment puis-je détecter lorsque la fonctionnalité de fichier .NET est "désactivée" dans Windows 7 / Vista?
Où trouver des modèles de conception d'interface utilisateur (UI) pour les applications Windows?