Fórum Ajuda Criar componente #557055

unit cspeedButton;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, {ComCtrls,} Forms,
  Dialogs, ImgList, CommCtrl, Menus, StdCtrls, RichEdit, Buttons, ExtCtrls,
  ShlObj, ShellApi {$IFDEF TNTUNICODE}, TntButtons{$ENDIF};

type

   TcspeedButton = class;

  TcToolButtonActionLink = class(TControlActionLink)
  protected
    FClient: TcspeedButton;
    procedure AssignClient(AClient: TObject); override;
    function IsCheckedLinked: Boolean; override;
    function IsImageIndexLinked: Boolean; override;
    procedure SetChecked(Value: Boolean); override;
    procedure SetImageIndex(Value: Integer); override;
  end;

  TcspeedButton = class(TSpeedButton)
  private
    { Private declarations }
    FImageIndex: TImageIndex;
    FImages: TCustomImageList;
    FImageChangeLink: TChangeLink;
    FNullBitmap: TBitmap;
    FOldHandle: HBitmap;
    FButtons: TList;

    procedure RecreateButtons;
    function IsImageIndexStored: Boolean;
    procedure SetImageIndex(Value: TImageIndex);
    procedure ImageListChange(Sender: TObject);
    procedure SetImageList(Value: HImageList);
    procedure SetImages(Value: TCustomImageList);
    procedure LoadImages(AImages: TCustomImageList);
    procedure UpdateImages;
    function GetButtonCount: Integer;
  protected
    { Protected declarations }
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    property ButtonCount: Integer read GetButtonCount;
  published
    { Published declarations }
    function GetActionLinkClass: TControlActionLinkClass; override;
    procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override;
    procedure AssignTo(Dest: TPersistent); override;
    procedure Notification(AComponent: TComponent; Operation: TOperation); override;
    property ImageIndex: TImageIndex read FImageIndex write SetImageIndex stored IsImageIndexStored default -1;
    property Images: TCustomImageList read FImages write SetImages;
  end;


procedure Register;

implementation

uses ActnList;

procedure Register;
begin
  RegisterComponents('Standard', [TcspeedButton]);
end;

{ TcspeedButton }

procedure TcspeedButton.ActionChange(Sender: TObject;
  CheckDefaults: Boolean);
begin
  inherited ActionChange(Sender, CheckDefaults);
  if Sender is TCustomAction then
    with TCustomAction(Sender) do
    begin
      if not CheckDefaults or not Self.Down then
        Self.Down := Checked;
      if not CheckDefaults or (Self.ImageIndex = -1) then
        Self.ImageIndex := ImageIndex;
    end;
end;

procedure TcspeedButton.AssignTo(Dest: TPersistent);
begin
  inherited AssignTo(Dest);
  if Dest is TCustomAction then
    with TCustomAction(Dest) do
    begin
      Checked := Self.Down;
      ImageIndex := Self.ImageIndex;
    end;
end;

constructor TcspeedButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  FButtons := TList.Create;
  FImageChangeLink := TChangeLink.Create;
  FImageChangeLink.OnChange := ImageListChange;
  FNullBitmap := TBitmap.Create;
  with FNullBitmap do
  begin
    Width := 1;
    Height := 1;
    Canvas.Brush.Color := clBtnFace;
    Canvas.FillRect(Rect(0,0,1,1));
  end;
end;


destructor TcspeedButton.Destroy;
begin
     FButtons.Free;
     FNullBitmap.Free;
     FImageChangeLink.Free;
  inherited Destroy;
end;

function TcspeedButton.GetActionLinkClass: TControlActionLinkClass;
begin
  Result := TcToolButtonActionLink;
end;

procedure TcspeedButton.ImageListChange(Sender: TObject);
begin
  if Parent.HandleAllocated and (Sender = Images) then
     RecreateButtons;
     //Repaint;
end;

function TcspeedButton.IsImageIndexStored: Boolean;
begin
 Result := (ActionLink = nil) or not TcToolButtonActionLink(ActionLink).IsImageIndexLinked;
end;

procedure TcspeedButton.LoadImages(AImages: TCustomImageList);
var
  AddBitmap: TTBAddBitmap;
  ReplaceBitmap: TTBReplaceBitmap;
  NewHandle: HBITMAP;

  function GetImageBitmap(ImageList: TCustomImageList): HBITMAP;
  var
    I: Integer;
    Bitmap: TBitmap;
    R: TRect;
  begin
    Bitmap := TBitmap.Create;
    try
      Bitmap.Width := ImageList.Width * ImageList.Count;
      Bitmap.Height := ImageList.Height;
      R := Rect(0,0,Width,Height);
      with Bitmap.Canvas do
      begin
        Brush.Color := clBtnFace;
        FillRect(R);
      end;
      for I := 0 to ImageList.Count - 1 do
        ImageList_Draw(ImageList.Handle, I, Bitmap.Canvas.Handle,
          I * ImageList.Width, 0, ILD_TRANSPARENT);
      Result := Bitmap.ReleaseHandle;
    finally
      Bitmap.Free;
    end;
  end;

begin
  if AImages <> nil then
    NewHandle := GetImageBitmap(AImages)
  else
    with TBitmap.Create do
    try
      Assign(FNullBitmap);
      NewHandle := ReleaseHandle;
    finally
      Free;
    end;
  if FOldHandle = 0 then
  begin
    AddBitmap.hInst := 0;
    AddBitmap.nID := NewHandle;
    Perform(TB_ADDBITMAP, ButtonCount, Longint(@AddBitmap));
  end
  else
  begin
    with ReplaceBitmap do
    begin
      hInstOld := 0;
      nIDOld := FOldHandle;
      hInstNew := 0;
      nIDNew := NewHandle;
      nButtons := ButtonCount;
    end;
    Perform(TB_REPLACEBITMAP, 0, Longint(@ReplaceBitmap));
    if FOldHandle <> 0 then DeleteObject(FOldHandle);
  end;
  FOldHandle := NewHandle;
end;

procedure TcspeedButton.UpdateImages;
begin
    if  Parent.HandleAllocated then LoadImages(FImages);
end;

procedure TcspeedButton.Notification(AComponent: TComponent;
  Operation: TOperation);
begin
  inherited Notification(AComponent, Operation);
  if Operation = opRemove then
  begin
    if AComponent = Images then
      Images := nil
  end;
end;

procedure TcspeedButton.RecreateButtons;
begin
  if ([csLoading, csDestroying] * ComponentState = []) or Parent.HandleAllocated then
  begin
    Repaint;
   UpdateImages;
  end;
end;

procedure TcspeedButton.SetImageIndex(Value: TImageIndex);
begin
  if FImageIndex <> Value then
  begin
    FImageIndex := Value;
    if (Visible or (csDesigning in ComponentState))  then
      RecreateButtons;
{    if FToolBar <> nil then
    begin
      RefreshControl;
      FToolBar.Perform(TB_CHANGEBITMAP, Index, Value);
      if FToolBar.Transparent or FToolBar.Flat then Invalidate;
    end; }
  end;
  end;

procedure TcspeedButton.SetImageList(Value: HImageList);
begin
  if Parent.HandleAllocated then Perform(TB_SETIMAGELIST, 0, Value);
  Invalidate;
end;

procedure TcspeedButton.SetImages(Value: TCustomImageList);
begin
  if Images <> Value then begin
    if Images <> nil then Images.UnRegisterChanges(FImageChangeLink);
    FImages := Value;
    if Images <> nil then begin
      Images.RegisterChanges(FImageChangeLink);
      Images.FreeNotification(Self);
    end;
  //else
    SetImageList(0);
  RecreateButtons;
end;
end;


function TcspeedButton.GetButtonCount: Integer;
begin
 Result := FButtons.Count;
end;

{ TcToolButtonActionLink }

procedure TcToolButtonActionLink.AssignClient(AClient: TObject);
begin
  inherited AssignClient(AClient);
  FClient := AClient as TcspeedButton;
end;

function TcToolButtonActionLink.IsCheckedLinked: Boolean;
begin
  Result := inherited IsCheckedLinked and
    (FClient.Down = (Action as TCustomAction).Checked);
end;

function TcToolButtonActionLink.IsImageIndexLinked: Boolean;
begin
  Result := inherited IsImageIndexLinked and
    (FClient.ImageIndex = (Action as TCustomAction).ImageIndex);
end;

procedure TcToolButtonActionLink.SetChecked(Value: Boolean);
begin
    if IsCheckedLinked then FClient.Down := Value;
end;

procedure TcToolButtonActionLink.SetImageIndex(Value: Integer);
begin
    if IsImageIndexLinked then FClient.ImageIndex := Value;
end;

end.