WinAPI Icon Btn

unit winapi_iconbtn;

interface

uses
  Windows, Messages;

type
  TShiftState = set of (ssShift, ssAlt, ssCtrl, ssLeft, ssRight, ssMiddle, ssDouble);
  TButtonLayout = (blGlyphLeft, blGlyphRight, blGlyphTop, blGlyphBottom);
  TMouseButton = (mbLeft, mbRight, mbMiddle);
  TMouseEvent = procedure(Sender : TObject; Button : TMouseButton;
    Shift : TShiftState; X, Y : integer) of object;
  TWndMethod = procedure(var Message : TMessage) of object;
  TNotifyEvent = procedure(Sender : TObject) of object;
  PObjectInstance = ^TObjectInstance;
  TObjectInstance = packed record
    Code : Byte;
    Offset : integer;
    case integer of
      0 : (Next : PObjectInstance);
      1 : (Method : TWndMethod);
  end;
  PInstanceBlock = ^TInstanceBlock;
  TInstanceBlock = packed record
    Next : PInstanceBlock;
    Code : array[1..2] of Byte;
    WndProcPtr : Pointer;
    Instances : array[0..313] of TObjectInstance;
  end;
  TWAIconBtn = class(TObject)
  private
    FAppFont : HFONT;
    FCaption : string;
    FIconHandle : HICON;
    FLayout : TButtonLayout;
    FOnClick : TNotifyEvent;
    FOnRightClick : TMouseEvent;
    FEnabled, FVisible : boolean;
    FHandle, FParentWindowHandle : HWND;
    FIdent, FLeft, FTop, FWidth, FHeight : integer;
    POldButtonProc, POldParentWindowProc : Pointer;
    procedure SetTop(Value : integer);
    procedure SetLeft(Value : integer);
    procedure SetWidth(Value : integer);
    procedure SetHeight(Value : integer);
    procedure SetCaption(Value : string);
    procedure SetEnabled(Value : boolean);
    procedure SetVisible(Value : boolean);
    procedure SetIconHandle(Value : HICON);
    procedure DoRightClick(Sender : TObject);
    procedure SetLayout(Value : TButtonLayout);
    procedure WndProc(var AMessage : TMessage);
    procedure RefreshStateOfTheControlByHidingAndShow;
    procedure ParentWindowProc(var AMessage : TMessage);
    procedure CalcButtonLayout(Canvas : HDC; const Client : TRect;
      const IconToDraw : HICON; const CaptionOfButton : string;
      const CaptionFont : HFONT; Layout : TButtonLayout;
      Margin, Spacing : integer; var GlyphPos, TextPos : TPoint);
    procedure DrawBitBtn(ParamDrawItem : PDrawItemStruct; BtnIconH : HICON; TextOfCaption : string);
  public
    procedure Click;
    destructor Destroy; override;
    constructor Create(ParentWindowHandle : HWND);
  published
    property Handle : HWND read FHandle;
    property Top : integer read FTop write SetTop;
    property Left : integer read FLeft write SetLeft;
    property Width : integer read FWidth write SetWidth;
    property Height : integer read FHeight write SetHeight;
    property Caption : string read FCaption write SetCaption;
    property Enabled : boolean read FEnabled write SetEnabled;
    property Visible : boolean read FVisible write SetVisible;
    property OnClick : TNotifyEvent read FOnClick write FOnClick;
    property Layout : TButtonLayout read FLayout write SetLayout;
    property IconHandle : HICON read FIconHandle write SetIconHandle;
    property OnRightClick : TMouseEvent read FOnRightClick write FonRightClick;
  end;

implementation

const
  Btn_Margin = -1;
  Btn_Spacing = 12;
  Button_ClassName = 'Button';
  WM_OWNERDRAW = WM_USER + 666;

var
  InstBlockList : PInstanceBlock;
  InstFreeList : PObjectInstance;

function Point(X, Y : integer) : TPoint;
begin
  Result.X := X;
  Result.Y := Y;
end;

function Rect(Left, Top, Right, Bottom : integer) : TRect;
begin
  Result.Left := Left;
  Result.Top := Top;
  Result.Bottom := Bottom;
  Result.Right := Right;
end;

function CalcJmpOffset(Src, Dest : Pointer) : Longint;
begin
  Result := Longint(Dest) - (Longint(Src) + 5);
end;

function StdWndProc(Window : HWND; Message, WParam : Longint;
  LParam : Longint) : Longint; stdcall; assembler;
asm
        XOR     EAX,EAX
        PUSH    EAX
        PUSH    LParam
        PUSH    WParam
        PUSH    Message
        MOV     EDX,ESP
        MOV     EAX,[ECX].Longint[4]
        CALL    [ECX].Pointer
        ADD     ESP,12
        POP     EAX
end;

function MakeObjectInstance(Method : TWndMethod) : Pointer;
const
  PageSize = 4096;
  BlockCode : array[1..2] of Byte = ($59, $E9);
var
  Block : PInstanceBlock;
  Instance : PObjectInstance;
begin
  if InstFreeList = nil then
  begin
    Block := VirtualAlloc(nil, PageSize, MEM_COMMIT, PAGE_EXECUTE_READWRITE);
    Block^.Next := InstBlockList;
    Move(BlockCode, Block^.Code, SizeOf(BlockCode));
    Block^.WndProcPtr := Pointer(CalcJmpOffset(@Block^.Code[2], @StdWndProc));
    Instance := @Block^.Instances;
    repeat
      Instance^.Code := $E8;
      Instance^.Offset := CalcJmpOffset(Instance, @Block^.Code);
      Instance^.Next := InstFreeList;
      InstFreeList := Instance;
      Inc(Longint(Instance), SizeOf(TObjectInstance));
    until Longint(Instance) - Longint(Block) >= SizeOf(TInstanceBlock);
    InstBlockList := Block;
  end;
  Result := InstFreeList;
  Instance := InstFreeList;
  InstFreeList := Instance^.Next;
  Instance^.Method := Method;
end;

function GetTextWidth(TextToCheck : string; GivenTextFonr : HFONT) : integer;
var
  DC : HDC;
  PStr : PChar;
  Size : TSize;
begin
  Result := 0;
  if TextToCheck <> '' then
  begin
    GetMem(PStr, Length(TextToCheck));
    CopyMemory(PStr, PChar(TextToCheck), Length(TextToCheck));
    DC := GetDC(0);
    SelectObject(DC, GivenTextFonr);
    GetTextExtentPoint32(DC, PStr, Length(TextToCheck), Size);
    ReleaseDC(0, DC);
    FreeMem(PStr);
    Result := Size.cx;
  end;
end;

function GetTextHeight(TextToCheck : string; GivenTextFonr : HFONT) : integer;
var
  DC : HDC;
  PStr : PChar;
  Size : TSize;
begin
  Result := 0;
  if TextToCheck <> '' then
  begin
    GetMem(PStr, Length(TextToCheck));
    CopyMemory(PStr, PChar(TextToCheck), Length(TextToCheck));
    DC := GetDC(0);
    SelectObject(DC, GivenTextFonr);
    GetTextExtentPoint32(DC, PStr, Length(TextToCheck), Size);
    ReleaseDC(0, DC);
    FreeMem(PStr);
    Result := Size.cy;
  end;
end;

procedure TWAIconBtn.RefreshStateOfTheControlByHidingAndShow;
begin
  ShowWindow(FHandle, SW_HIDE);
  if FVisible then
  begin
    ShowWindow(FHandle, SW_SHOW);
  end;
end;

procedure TWAIconBtn.WndProc(var AMessage : TMessage);
var
  FDrawItem : PDrawItemStruct;

begin
  with AMessage do
  begin
    case Msg of
      WM_OWNERDRAW :
        begin
          FDrawItem := Pointer(LParam);
          DrawBitBtn(FDrawItem, FIconHandle, FCaption);
        end;
      wM_SETCURSOR :
        begin
          if IsWindowEnabled(FHandle) then
          begin
            SetCursor(LoadCursor(0, IDC_HAND));
            AMessage.Result := 0;
            Exit;
          end;
        end;
      WM_LBUTTONUP :
        begin
          if Assigned(FOnClick) then
          begin
            FOnClick(Self);
          end;
        end;
      WM_RBUTTONUP :
        begin
          DoRightClick(Self);
        end;
    end;
    if POldButtonProc <> nil then
    begin
      Result := CallWindowProc(POldButtonProc, Self.Handle, Msg, WParam, LParam);
    end;
  end;
end;

procedure TWAIconBtn.ParentWindowProc(var AMessage : TMessage);
var
  FDrawItem : PDrawItemStruct;
begin
  with AMessage do
  begin
    case Msg of
      WM_DRAWITEM :
        begin
          FDrawItem := Pointer(LParam);
          if FDrawItem.hwndItem = Fhandle then
          begin
            SendMessage(FDrawItem.hwndItem, WM_OWNERDRAW, WParam, LParam);
          end;
        end
    else
      begin
        Result := CallWindowProc(POldParentWindowProc, FParentWindowHandle, Msg, WParam, LParam);
      end;
    end;
  end;
end;

procedure TWAIconBtn.CalcButtonLayout(Canvas : HDC; const Client : TRect;
  const IconToDraw : HICON; const CaptionOfButton : string;
  const CaptionFont : HFONT; Layout : TButtonLayout;
  Margin, Spacing : integer; var GlyphPos, TextPos : TPoint);
var
  TextBounds : TRect;
  TotalSize : TPoint;
  BMInfo : TagBITMAP;
  IconInfo : TIconInfo;
  ClientSize, GlyphSize, TextSize : TPoint;
begin
  if IconToDraw > 0 then
  begin
    if GetIconInfo(IconToDraw, IconInfo) then
    begin
      if GetObject(IconInfo.hbmColor, SizeOf(BMInfo), @BMInfo) > 0 then
      begin
        GlyphSize.X := BMInfo.bmWidth;
        GlyphSize.Y := BMInfo.bmHeight;
      end
      else
      begin
        GlyphSize.X := 0;
        GlyphSize.Y := 0;
      end;
    end;
  end
  else
  begin
    GlyphSize.X := 0;
    GlyphSize.Y := 0;
  end;
  ClientSize := Point(Client.Right - Client.Left, Client.Bottom - Client.Top);
  if Length(CaptionOfButton) > 0 then
  begin
    TextBounds := Rect(0, 0, Client.Right - Client.Left, 0);
    DrawText(Canvas, PChar(CaptionOfButton), Length(CaptionOfButton), TextBounds, DT_CALCRECT);
    TextSize.X := GetTextWidth(CaptionOfButton, CaptionFont);
    TextSize.Y := GetTextHeight(CaptionOfButton, CaptionFont);
  end
  else
  begin
    TextBounds := Rect(0, 0, 0, 0);
    TextSize := Point(0, 0);
  end;
  if Layout in [blGlyphLeft, blGlyphRight] then
  begin
    GlyphPos.Y := (ClientSize.Y - GlyphSize.Y + 1) div 2;
    TextPos.Y := (ClientSize.Y - TextSize.Y + 1) div 2;
  end
  else
  begin
    GlyphPos.X := (ClientSize.X - GlyphSize.X + 1) div 2;
    TextPos.X := (ClientSize.X - TextSize.X + 1) div 2;
  end;
  if (TextSize.X = 0) or (GlyphSize.X = 0) then
  begin
    Spacing := 0;
  end;
  if Margin = -1 then
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(GlyphSize.X + TextSize.X, GlyphSize.Y + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
      begin
        Margin := (ClientSize.X - TotalSize.X) div 3
      end
      else
      begin
        Margin := (ClientSize.Y - TotalSize.Y) div 3;
      end;
      Spacing := Margin;
    end
    else
    begin
      TotalSize := Point(GlyphSize.X + Spacing + TextSize.X, GlyphSize.Y +
        Spacing + TextSize.Y);
      if Layout in [blGlyphLeft, blGlyphRight] then
      begin
        Margin := (ClientSize.X - TotalSize.X + 1) div 2
      end
      else
      begin
        Margin := (ClientSize.Y - TotalSize.Y + 1) div 2;
      end;
    end;
  end
  else
  begin
    if Spacing = -1 then
    begin
      TotalSize := Point(ClientSize.X - (Margin + GlyphSize.X), ClientSize.Y -
        (Margin + GlyphSize.Y));
      if Layout in [blGlyphLeft, blGlyphRight] then
      begin
        Spacing := (TotalSize.X - TextSize.X) div 2
      end
      else
      begin
        Spacing := (TotalSize.Y - TextSize.Y) div 2;
      end;
    end;
  end;
  case Layout of
    blGlyphLeft :
      begin
        GlyphPos.X := Margin;
        TextPos.X := GlyphPos.X + GlyphSize.X + Spacing;
      end;
    blGlyphRight :
      begin
        GlyphPos.X := ClientSize.X - Margin - GlyphSize.X;
        TextPos.X := GlyphPos.X - Spacing - TextSize.X;
      end;
    blGlyphTop :
      begin
        GlyphPos.Y := Margin;
        TextPos.Y := GlyphPos.Y + GlyphSize.Y + Spacing;
      end;
    blGlyphBottom :
      begin
        GlyphPos.Y := ClientSize.Y - Margin - GlyphSize.Y;
        TextPos.Y := GlyphPos.Y - Spacing - TextSize.Y;
      end;
  end;
end;

procedure TWAIconBtn.DrawBitBtn(ParamDrawItem : PDrawItemStruct; BtnIconH : HICON; TextOfCaption : string);
const
  Icon_Param_Arr : array[boolean] of UINT = (0, DSS_DISABLED);
var
  OldFont : HFONT;
  IconPos, TxtPos : TPoint;
begin
  CalcButtonLayout(ParamDrawItem.HDC, ParamDrawItem.rcItem, FIconHandle,
    TextOfCaption, FAppFont, FLayout, Btn_Margin, Btn_Spacing, IconPos, TxtPos);
  DrawState(ParamDrawItem.HDC, 0, nil, BtnIconH, 0,
    ParamDrawItem.rcItem.Left + IconPos.X,
    ParamDrawItem.rcItem.top + IconPos.Y, 0, 0, DST_ICON or
    Icon_Param_Arr[ParamDrawItem.itemState = ODS_DISABLED]);
  OldFont := SelectObject(ParamDrawItem.HDC, FAppFont);
  if ParamDrawItem.itemState = ODS_DISABLED then
  begin
    SetTextColor(ParamDrawItem.HDC, GetSysColor(COLOR_BTNSHADOW));
    if TextOfCaption <> '' then
    begin
      TextOut(ParamDrawItem.hDC, TxtPos.X, TxtPos.Y, PChar(TextOfCaption), Length(TextOfCaption));
    end;
  end
  else
  begin
    if TextOfCaption <> '' then
    begin
      TextOut(ParamDrawItem.hDC, TxtPos.X, TxtPos.Y, PChar(TextOfCaption), Length(TextOfCaption));
    end;
  end;
  if (ParamDrawItem.itemState and ODS_SELECTED) <> 0 then
  begin
    DrawEdge(ParamDrawItem.HDC, ParamDrawItem.rcItem, EDGE_SUNKEN, BF_RECT);
  end
  else
  begin
    DrawEdge(ParamDrawItem.HDC, ParamDrawItem.rcItem, EDGE_RAISED, BF_RECT);
  end;
  if ParamDrawItem.itemState = ODS_FOCUS then
  begin
    InflateRect(ParamDrawItem.rcItem, -4, -4);
    DrawFocusRect(ParamDrawItem.HDC, ParamDrawItem.rcItem);
  end;
  SelectObject(ParamDrawItem.HDC, OldFont);
end;

procedure TWAIconBtn.Click;
begin
  if Assigned(FOnClick) then
  begin
    FOnClick(Self);
  end;
end;

destructor TWAIconBtn.Destroy;
begin
  SetWindowLong(FParentWindowHandle, GWL_WNDPROC, Longint(POldParentWindowProc));
  DestroyWindow(FHandle);
  inherited Destroy;
end;

constructor TWAIconBtn.Create(ParentWindowHandle : HWND);
begin
  FParentWindowHandle := ParentWindowHandle;
  if IsWindow(FParentWindowHandle) then
  begin
    FTop := 4;
    FLeft := 6;
    FWidth := 140;
    FHeight := 100;
    FCaption := '';
    FEnabled := True;
    FVisible := True;
    FIconHandle := 0;
    FHandle := CreateWindowEx(0, Button_ClassName, '',
      WS_CHILDWINDOW or WS_VISIBLE or WS_TABSTOP or BS_OWNERDRAW,
      FLeft, FTop, FWidth, FHeight,
      FParentWindowHandle, 0, HInstance, nil);
    if FHandle > 0 then
    begin
      Randomize;
      repeat
        FIdent := Random(High(WORD) + 1);
      until GetDlgItem(FParentWindowHandle, FIdent) <> FHandle;
      SetWindowLong(FHandle, GWL_ID, FIdent);
      POldButtonProc := Pointer(SetWindowLong(FHandle, GWL_WNDPROC, Longint(MakeObjectInstance(WndProc))));
      POldParentWindowProc := Pointer(SetWindowLong(FParentWindowHandle, GWL_WNDPROC, Longint(MakeObjectInstance(ParentWindowProc))));
    end;
  end;
end;

procedure TWAIconBtn.SetTop(Value : integer);
begin
  if FTop <> Value then
  begin
    FTop := Value;
    SetWindowPos(FHandle, HWND_TOP, FLeft, FTop, FWidth, FHeight, SWP_NOZORDER);
  end;
end;

procedure TWAIconBtn.SetLeft(Value : integer);
begin
  if FLeft <> Value then
  begin
    FLeft := Value;
    SetWindowPos(FHandle, HWND_TOP, FLeft, FTop, FWidth, FHeight, SWP_NOZORDER);
  end;
end;

procedure TWAIconBtn.SetWidth(Value : integer);
begin
  if FWidth <> Value then
  begin
    FWidth := Value;
    SetWindowPos(FHandle, HWND_TOP, FLeft, FTop, FWidth, FHeight, SWP_NOZORDER);
  end;
end;

procedure TWAIconBtn.SetHeight(Value : integer);
begin
  if FWidth <> Value then
  begin
    FHeight := Value;
    SetWindowPos(FHeight, HWND_TOP, FLeft, FTop, FWidth, FHeight, SWP_NOZORDER);
  end;
end;

procedure TWAIconBtn.SetCaption(Value : string);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    RefreshStateOfTheControlByHidingAndShow;
  end;
end;

procedure TWAIconBtn.SetEnabled(Value : boolean);
begin
  if FEnabled <> Value then
  begin
    FEnabled := Value;
    EnableWindow(FHandle, FEnabled);
  end;
end;

procedure TWAIconBtn.SetVisible(Value : boolean);
begin
  if FVisible <> Value then
  begin
    FVisible := Value;
    if FVisible then
    begin
      ShowWindow(FHandle, SW_SHOW)
    end
    else
    begin
      ShowWindow(FHandle, SW_HIDE);
    end;
  end;
end;

procedure TWAIconBtn.SetIconHandle(Value : HICON);
begin
  if FIconHandle <> Value then
  begin
    FIconHandle := Value;
    RefreshStateOfTheControlByHidingAndShow;
  end;
end;

procedure TWAIconBtn.DoRightClick(Sender : TObject);
var
  MouseCo : TPoint;
begin
  GetCursorPos(MouseCo);
  if Assigned(FOnRightClick) then
  begin
    FOnRightClick(Self, mbRight, [], MouseCo.X, MouseCo.Y);
  end;
end;

procedure TWAIconBtn.SetLayout(Value : TButtonLayout);
begin
  if FLayout <> Value then
  begin
    FLayout := Value;
    RefreshStateOfTheControlByHidingAndShow;
  end;
end;

end.