Barra de título transparente en los formularios

[[escafandra]]

Finalmente he conseguido un ratito libre y he realizado alguna modificación en el componente sin perder la esencia del original. El error estaba en cuando se permitía el Hook al WinProc del Owner. No se debe permitir en fase de diseño...

Muestro aquí los pequeños cambios que realicé:

Código Delphi [-]
unit AlphaTitleBar;

interface

uses
  SysUtils, Classes, Forms, Messages, Windows;

type
  TAlphaTitleBar = class(TComponent)
  private
    { Private declarations }
    FForm: TForm;
    FActive: Boolean;
    FTransparencyValue: Byte;
    FOldOwnerAlphaBlendValue: Byte;
    FOldOwnerAlphaBlend: boolean;
    OldWndProc: TFarProc;
    NewWndProc: Pointer;
    procedure HookOwner;
    procedure UnhookOwner;
    procedure CreateFForm;
    procedure DestroyFForm;
    Procedure SetActive(value: Boolean);
    Procedure SetTransparencyValue(value: Byte);
    Procedure UpdateWndProcAndOnCreate;
  protected
    { Protected declarations }
    procedure CallDefault(var Msg: TMessage);
    procedure HookWndProc(var Message: TMessage); virtual;
  public
    { Public declarations }
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    { Published declarations }
    Property Active: Boolean read FActive write SetActive default False;
    Property TransparencyValue: Byte read FTransparencyValue
      write SetTransparencyValue default 170;
  end;

procedure Register;

implementation
{$WARN SYMBOL_DEPRECATED OFF}

procedure Register;
begin
  RegisterComponents('GenioEscafandra', [TAlphaTitleBar]);;  //<--En homenaje a Escafandra
end;

{ TAlphaTitleBar }

procedure TAlphaTitleBar.CallDefault(var Msg: TMessage);
begin
  Msg.Result := CallWindowProc(OldWndProc, TForm(Owner).Handle, Msg.Msg,
    Msg.wParam, Msg.lParam);
end;

constructor TAlphaTitleBar.Create(AOwner: TComponent);
Var
  I: Integer;
begin
  if not(AOwner is TForm) then
    raise EInvalidCast.Create
      ('El componente TAlphaTitleBar solo puede ser colocado en un TForm o en sus descendientes.');
  with AOwner do
    for I := 0 to ComponentCount - 1 do
      if (Components[i] is TAlphaTitleBar) and (Components[i] <> Self) then
        raise EComponentError.Create
          ('Solo se permite un solo componente TAlphaTitleBar en un formulario.');
  inherited Create(AOwner);
  NewWndProc:= nil;
  FOldOwnerAlphablendValue:= TForm(Owner).AlphaBlendValue;
  FOldOwnerAlphablend:= TForm(Owner).AlphaBlend;

  Active := False;
  TransparencyValue := 170;
end;

procedure TAlphaTitleBar.CreateFForm;
begin
  with (Owner as TForm) do
  begin
    FForm := TForm.Create(nil);
    FForm.BorderStyle := bsNone;
    FForm.Left := Left + GetSystemMetrics(SM_CXFRAME);
    FForm.Top := Top + GetSystemMetrics(SM_CYCAPTION) +
      GetSystemMetrics(SM_CYFRAME);
    FForm.Width := Width - 2 * GetSystemMetrics(SM_CXFRAME);
    FForm.Height := Height - GetSystemMetrics(SM_CYCAPTION) - 2 *
      GetSystemMetrics(SM_CYFRAME);
    FForm.Show;

    while ControlCount > 0 do
      Controls[0].Parent := FForm;

    SendMessage(Handle, WM_NCACTIVATE, ShortInt(True), 0);
  end;
end;
destructor TAlphaTitleBar.Destroy;
begin
  if (Owner <> nil) then
  begin
    TForm(Owner).AlphablendValue:= FOldOwnerAlphaBlendValue;
    TForm(Owner).Alphablend:= FOldOwnerAlphaBlend;
  end;
  UnhookOwner;
  DestroyFForm;
  inherited Destroy;
end;

procedure TAlphaTitleBar.DestroyFForm;
begin
  if Assigned(FForm) then
  begin
    while FForm.ControlCount > 0 do
      FForm.Controls[0].Parent := (Owner as TForm);
    FreeAndNil(FForm);
  end;
end;

procedure TAlphaTitleBar.HookWndProc(var Message: TMessage);
begin
  with (Owner as TForm) do
  Begin
    case Message.Msg of
      WM_SYSCOMMAND:
        case Message.wParam of
          SC_MAXIMIZE, SC_MINIMIZE, SC_RESTORE:
          begin
            SetWindowPos(FForm.Handle, 0, Left + GetSystemMetrics(SM_CXFRAME),
              Top + GetSystemMetrics(SM_CYCAPTION) +
              GetSystemMetrics(SM_CYFRAME),
              Width - 2 * GetSystemMetrics(SM_CXFRAME),
              Height - GetSystemMetrics(SM_CYCAPTION) - 2 *
              GetSystemMetrics(SM_CYFRAME), 0);
           end;   
        end;
      WM_CLOSE:
        FForm.Close;
      WM_MOVING:
        SetWindowPos(FForm.Handle, 0, PRECT(Message.lParam).Left +
          GetSystemMetrics(SM_CXFRAME), PRECT(Message.lParam).Top +
          GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME), 0, 0,
          SWP_NOSIZE);
      WM_SIZING:
        SetWindowPos(FForm.Handle, 0, PRECT(Message.lParam).Left +
          GetSystemMetrics(SM_CXFRAME), PRECT(Message.lParam).Top +
          GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME),
          PRECT(Message.lParam).Right - PRECT(Message.lParam).Left - 2 *
          GetSystemMetrics(SM_CXFRAME), PRECT(Message.lParam).Bottom -
          PRECT(Message.lParam).Top - GetSystemMetrics(SM_CYCAPTION) - 2 *
          GetSystemMetrics(SM_CYFRAME), 0);
      WM_SIZE:
        if FForm <> nil then
          SetWindowPos(FForm.Handle, 0, Left + GetSystemMetrics(SM_CXFRAME),
            Top + GetSystemMetrics(SM_CYCAPTION) + GetSystemMetrics(SM_CYFRAME),
            Width - 2 * GetSystemMetrics(SM_CXFRAME),
            Height - GetSystemMetrics(SM_CYCAPTION) - 2 *
            GetSystemMetrics(SM_CYFRAME), 0);
      WM_SETFOCUS:
      begin
        PostMessage(FForm.Handle, WM_SETFOCUS, 0, 0);
      end;
    end;
    CallDefault(Message);
  End;
end;

procedure TAlphaTitleBar.SetActive(value: Boolean);
begin
  if value <> FActive then
  begin
    FActive := value;
    TForm(Owner).AlphaBlend := value;
    TForm(Owner).Invalidate;
    UpdateWndProcAndOnCreate;
  end;  
end;

procedure TAlphaTitleBar.SetTransparencyValue(value: Byte);
begin
  if value <> FTransparencyValue then
  begin
    FTransparencyValue := value;
    TForm(Owner).AlphaBlendValue := value;
    TForm(Owner).Invalidate;
  end;
end;

procedure TAlphaTitleBar.HookOwner;
begin
  if not Assigned(Owner) or (NewWndProc <> nil) then
    Exit;
  OldWndProc := TFarProc(GetWindowLong(TForm(Owner).Handle, GWL_WndProc));
  NewWndProc := MakeObjectInstance(HookWndProc);
  SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(NewWndProc))
end;

procedure TAlphaTitleBar.UnhookOwner;
begin
  if Assigned(Owner) and Assigned(OldWndProc) then
    SetWindowLong(TForm(Owner).Handle, GWL_WndProc, LongInt(OldWndProc));
  if Assigned(NewWndProc) then
    FreeObjectInstance(NewWndProc);
  NewWndProc := nil;
//  OldWndProc := nil
end;

procedure TAlphaTitleBar.UpdateWndProcAndOnCreate;
begin
  if FActive and not(csDesigning in ComponentState) then
  begin
    if NewWndProc = nil then
    begin
      CreateFForm;
      HookOwner;
    end;
  end
  else
  begin
    UnhookOwner;
    DestroyFForm;
  end;
  TForm(Owner).Invalidate;
end;

end.

Saludos.