XP Themes in Delphi 2009 Add-in

[Slava Barouline]

Hi

I am trying to move to Delphi 2009 my exisitng Add-in written in Delphi

2006 - to support unicode.

There was a hack in Controls.pas to make Message boxes support XP Themes,

but I cannot make it work for Delphi 2009 though I do the same changes for

Delphi 2009 Controls.pas.

procedure TWinControl.CreateHandle;

var

I: Integer;

//new code

Buffer : array[0..MAX_PATH] of Char;

act : TActCTXA;

bContextActivated : boolean ;

m_hActCtx : THANDLE ;

Cookie : Pointer ;

err : integer;

begin

if FHandle = 0 then

begin

//new code

m_hActCtx:=0;

bContextActivated:=false;

//Windows XP and up

if (Win32Platform = VER_PLATFORM_WIN32_NT) and

((Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and

(Win32MinorVersion >= 1)))

then begin

if GetModuleFileName(0, Buffer, SizeOf(Buffer)) > 0 then begin

//hosting exe (outlook.exe)

ZeroMemory(@act, SizeOf(act));

act.dwFlags := ACTCTX_FLAG_RESOURCE_NAME_VALID or

ACTCTX_FLAG_HMODULE_VALID;

act.lpResourceName := MAKEINTRESOURCE(2); //there must be a manifest

resource in the dll

act.cbSize := sizeof(act);

act.lpSource := Buffer;

act.hModule:=HInstance;

m_hActCtx := CreateActCtxA(act);

if (m_hActCtx <> 0) then begin

bContextActivated:=ActivateActCtx(m_hActCtx, Cookie);

if not bContextActivated then begin

err:=GetLastError;

if err = 0 then;

end;

end;

end;

end;

try

//old code

CreateWnd;

SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self));

SetProp(FHandle, MakeIntAtom(WindowAtom), THandle(Self));

if Parent <> nil then

SetWindowPos(FHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,

SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);

for I := 0 to ControlCount - 1 do

Controls.UpdateAnchorRules;

//end old code

finally

if bContextActivated then DeactivateActCtx(0, Cookie);

if m_hActCtx <> 0 then ReleaseActCtx(m_hActCtx);

end;

end;

end;

I was wondering if somebody already has done it.

I would appretiate some help here.

Thanks

 

[Slava Barouline]

Re: XP Themes in Delphi 2009 Add-in - solved

I have done a similar hack in Controls.pas and it works OK with message

boxes

procedure TWinControl.CreateHandle;

var

I: Integer;

//

Buffer : array[0..MAX_PATH] of Char;

act : TActCTXA;

bContextActivated : boolean ;

m_hActCtx : THANDLE ;

Cookie : Pointer ;

err : integer;

begin

if WindowHandle = 0 then

begin

//

m_hActCtx:=0;

bContextActivated:=false;

//Windows XP and up

if (Win32Platform = VER_PLATFORM_WIN32_NT) and

((Win32MajorVersion > 5) or ((Win32MajorVersion = 5) and

(Win32MinorVersion >= 1)))

then begin

if GetModuleFileName(0, Buffer, SizeOf(Buffer)) > 0 then begin

//hosting exe (outlook.exe)

ZeroMemory(@act, SizeOf(act));

act.dwFlags := ACTCTX_FLAG_RESOURCE_NAME_VALID or

ACTCTX_FLAG_HMODULE_VALID;

act.lpResourceName := PAnsiChar(AnsiChar(MAKEINTRESOURCE(2)));

//there must be a manifest resource in the dll

act.cbSize := sizeof(act);

act.lpSource := PAnsiChar(AnsiString(Buffer));

act.hModule:=HInstance;

m_hActCtx := CreateActCtxA(act);

if (m_hActCtx <> 0) then begin

bContextActivated:=ActivateActCtx(m_hActCtx, Cookie);

if not bContextActivated then begin

err:=GetLastError;

if err = 0 then;

end;

end;

end;

end;

try

//old code

CreateWnd;

{$IF NOT DEFINED(CLR)}

SetProp(FHandle, MakeIntAtom(ControlAtom), THandle(Self));

SetProp(FHandle, MakeIntAtom(WindowAtom), THandle(Self));

{$IFEND}

if Parent <> nil then

SetWindowPos(WindowHandle, Parent.PrecedingWindow(Self), 0, 0, 0, 0,

SWP_NOMOVE + SWP_NOSIZE + SWP_NOACTIVATE);

for I := 0 to ControlCount - 1 do

Controls.UpdateAnchorRules;

//end old code

finally

if bContextActivated then DeactivateActCtx(0, Cookie);

if m_hActCtx <> 0 then ReleaseActCtx(m_hActCtx);

end;

end;

end;