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
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
procedure CallDefault(var Msg: TMessage);
procedure HookWndProc(var Message: TMessage); virtual;
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
published
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]);; end;
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;
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.