AGB  ·  Datenschutz  ·  Impressum  







Anmelden
Nützliche Links
Registrieren
Thema durchsuchen
Ansicht
Themen-Optionen

Transparente Menüs unter XP

Ein Thema von toms · begonnen am 3. Jul 2002 · letzter Beitrag vom 3. Jul 2002
 
Benutzerbild von toms
toms
(CodeLib-Manager)

Registriert seit: 10. Jun 2002
4.648 Beiträge
 
Delphi XE Professional
 
#1

Transparente Menüs unter XP

  Alt 3. Jul 2002, 10:06
Hi,

Ich probier grad unter XP transparente Menüs anzuzeigen.
Die Idee kommt von diesem Artikel:
http://www.codeproject.com/menu/trans_menu.asp

Dafür muss man das Mainmenu subclassen. Hab mal den
Code soweit nach Delphi übersetzt [1] (mit meinen bescheidenen
C Kenntnissen). Soweit so gut. Aber: In der SubClassWndProc
Funktion erscheint bei CallWindowProc() immer eine Fehlermeldung [2].
Dieser Fehler tritt ein, wenn das Mainmenü geöffnet wird.
Vielleicht hat ja jemand eine Idee, wo der (oder die) Fehler steckt/stecken.

thx

tom



[1]
Code:
var
  hHookID: HHOOK;

implementation

{$R *.dfm} 

function MakeWndTrans(Wnd: HWND; nAlpha: Integer = 10): Boolean;
type
  TSetLayeredWindowAttributes = function(hwnd: HWND; crKey: COLORREF; bAlpha: Byte;
    dwFlags: Longint): Longint;
  stdcall;
const
  // Use crKey as the transparency color.
  LWA_COLORKEY = 1;
  // Use bAlpha to determine the opacity of the layered window..
  LWA_ALPHA = 2;
  WS_EX_LAYERED = $80001;
var
  hUser32: HMODULE;
  SetLayeredWindowAttributes: TSetLayeredWindowAttributes;
begin
  Result := False;
  // Here we import the function from USER32.DLL
  hUser32 := GetModuleHandle('USER32.DLL');
  if hUser32 <> 0 then
  begin @SetLayeredWindowAttributes := GetProcAddress(hUser32,
      'SetLayeredWindowAttributes');
    // If the import did not succeed, make sure your app can handle it! 
    if @SetLayeredWindowAttributes <> nil then
    begin
      // Check the current state of the dialog, and then add the WS_EX_LAYERED attribute
      SetWindowLong(Wnd, GWL_EXSTYLE, GetWindowLong(Wnd, GWL_EXSTYLE) or WS_EX_LAYERED);
      SetLayeredWindowAttributes(Wnd, 0, Trunc((255 / 100) * (100 - nAlpha)), LWA_ALPHA);
      Result := True;
    end;
  end;
end;

function SubClassWndProc(Wnd: HWND; uMsg: Longword; wParam: wParam;
  lParam: lParam): Longint; stdcall;
var
  OldWndProc: THandle;
begin
  OldWndProc := GetProp(Wnd, 'OldWndProc');
  case uMsg of
    WM_CREATE:
      begin
        MakeWndTrans(Wnd);
      end;
    WM_DESTROY:
      begin
        RemoveProp(Wnd, 'OldWndProc');
        SetWindowLong(Wnd, GWL_WNDPROC, Integer(OldWndProc));
      end;
  end;
  try
    Result := CallWindowProc(@OldWndProc, Wnd, uMsg, wParam, lParam); // Error !!!! 
  except
    RaiseLastWin32Error
  end;
end;

function HookCallWndProc(nCode: Integer; wParam, lParam: Longint): Longint; stdcall;
var
  cwps: TCWPStruct;
  lRet: THandle;
  szClass: array[0..8] of char;
begin
  if (nCode = HC_ACTION) then
  begin
    CopyMemory(@cwps, Pointer(lParam), SizeOf(CWPSTRUCT));
    case cwps.message of
      WM_CREATE:
        begin
          GetClassName(cwps.hwnd, szClass, Length(szClass) - 1);
          // Window name for menu is #32768 
          if (lstrcmpi(szClass, '#32768') = 0) then
          begin
            // Subclassing stuff
            lRet := SetWindowLong(cwps.hwnd, GWL_WNDPROC, Integer(@SubClassWndProc));
            // replace Window Proc
            SetProp(cwps.hwnd, 'OldWndProc', lRet);
            // Save Old Proc.
          end;
        end;
    end;
  end;
  // Call the next hook in the chain
  Result := CallNextHookEx(WH_CALLWNDPROC, nCode, wParam, lParam);
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  tpid: DWORD;
begin
  // retrieve the identifier of the thread that created the specified window
  tpid := GetWindowThreadProcessId(Handle, nil);
  // Install a WH_CALLWNDPROC hook
  hHookID := SetWindowsHookEx(WH_CALLWNDPROC, HookCallWndProc, 0, tpid);
end;

procedure TForm1.FormDestroy(Sender: TObject);
begin
  if (hHookID <> 0) then
    // Removes the hook procedure
    UnhookWindowsHookEx(hHookID);
end;
[2]
RaiseLastWin32Error zeigt den Fehler
"A call to an OS function failed" an.
Thomas
  Mit Zitat antworten Zitat
 


Forumregeln

Es ist dir nicht erlaubt, neue Themen zu verfassen.
Es ist dir nicht erlaubt, auf Beiträge zu antworten.
Es ist dir nicht erlaubt, Anhänge hochzuladen.
Es ist dir nicht erlaubt, deine Beiträge zu bearbeiten.

BB-Code ist an.
Smileys sind an.
[IMG] Code ist an.
HTML-Code ist aus.
Trackbacks are an
Pingbacks are an
Refbacks are aus

Gehe zu:

Impressum · AGB · Datenschutz · Nach oben
Alle Zeitangaben in WEZ +1. Es ist jetzt 13:03 Uhr.
Powered by vBulletin® Copyright ©2000 - 2025, Jelsoft Enterprises Ltd.
LinkBacks Enabled by vBSEO © 2011, Crawlability, Inc.
Delphi-PRAXiS (c) 2002 - 2023 by Daniel R. Wolf, 2024-2025 by Thomas Breitkreuz