Win7 64位下Delphi7 TPageControl无法自绘，求解决

[DelisPhi]

如果把一个PageControl的OwnerDraw属性置为True，style置为fsFlatButtons，并给他的OnDrawTab写下一段代码：

procedure TForm1.PageControl1DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
begin
    TPageControl(Control).Canvas.Brush.Color := clLime;
    If Active Then TPageControl(Control).Canvas.Brush.Color := $00CCFFCC Else TPageControl(Control).Canvas.Brush.Color := $00EADBCB;// G_PageTabBgColor[Random(G_PageColorMaxNum)];//$00CCFFCC;//$00CEE8CA;//cllime;
    TPageControl(Control).Canvas.FillRect(Rect);

    //---------写字
    Control.Canvas.TextRect(Rect,Rect.Left + 20, Rect.Top + 4, 'AText');

end;

编译出来的程序在32位XP，32位Win7下都可以实现改变PageControl顶部按钮的背景颜色；但是64位 Win7里面运行，就相当于OwnerDraw为False，但是没有字的情况。不知是啥问题。

[bwsoft1]

需要打个补丁文件，或者修改paint过程

[DelisPhi]

引用 1 楼 bwsoft1 的回复:

需要打个补丁文件，或者修改paint过程

啥补丁文件，有地址不？ 如果修改Paint过程，有没有具体点的步骤或者代码，本人比较菜不大会动系统内置的东东。。在此先谢过。。

[DelisPhi]

自己顶一下，没人遇到过这个问题么。。

[bwsoft1]

goole搜下，前段时间搜到过

[lyhoo163]

试过了，WIN7 32位完好 ，64位有问题，未画字符和颜色。

[DelisPhi]

根据bwsoft1的提示在google狂搜一顿后有了解决方法。 把以下代码另存为VCLFixes.pas，然后uses它，就搞定了，膜拜一下编写这个东东的大牛

unit VCLFixes;

interface

implementation

uses
Messages, Windows, Controls, Dialogs;

// WMDrawItem fails under WOW64, see http://qc.codegear.com/wc/qcmain.aspx?d=19859

{$IFDEF VER150} // Delphi7

function GetMethodAddress(AMessageID: Word; AClass: TClass; out MethodAddr: Pointer): Boolean;
var
DynamicTableAddress: Pointer;
MethodEntry: ^Pointer;
MessageHandlerList: PWord;
EntryCount, EntryIndex: Word;
begin
Result := False;

DynamicTableAddress := Pointer(PInteger(Integer(AClass) + vmtDynamicTable)^);
MessageHandlerList := PWord(DynamicTableAddress);
EntryCount := MessageHandlerList^;

if EntryCount > 0 then
for EntryIndex := EntryCount - 1 downto 0 do
begin
Inc(MessageHandlerList);
if (MessageHandlerList^ = AMessageID) then
begin
Inc(MessageHandlerList);
MethodEntry := Pointer(Integer(MessageHandlerList) + 2 * (2 * EntryCount - EntryIndex) - 4);
MethodAddr := MethodEntry^;
Result := True;
end;
end;
end;

function PatchInstructionByte(MethodAddress: Pointer; ExpectedOffset: Cardinal;
ExpectedValue: Byte; NewValue: Byte): Boolean;
var
BytePtr: PByte;
OldProtect: Cardinal;
begin
Result := False;

BytePtr := PByte(Cardinal(MethodAddress) + ExpectedOffset);

if BytePtr^ = NewValue then
begin
Result := True;
Exit;
end;

if BytePtr^ <> ExpectedValue then
Exit;

if VirtualProtect(BytePtr, SizeOf(BytePtr^), PAGE_EXECUTE_READWRITE, OldProtect) then
begin
try
BytePtr^ := NewValue;
Result := True;
finally
Result := Result
and VirtualProtect(BytePtr, SizeOf(BytePtr^), OldProtect, OldProtect)
and FlushInstructionCache(GetCurrentProcess, BytePtr, SizeOf(BytePtr^));
end;
end;
end;

function PatchInstructionBytes(MethodAddress: Pointer; ExpectedOffset: Cardinal;
const ExpectedValues: array of Byte; const NewValues: array of Byte;
const PatchedValues: array of Byte): Boolean;
var
BytePtr, TestPtr: PByte;
OldProtect, Index, PatchSize: Cardinal;
begin
BytePtr := PByte(Cardinal(MethodAddress) + ExpectedOffset);

Result := True;
TestPtr := BytePtr;
for Index := Low(PatchedValues) to High(PatchedValues) do
begin
if TestPtr^ <> PatchedValues[Index] then
begin
Result := False;
Break;
end;
Inc(TestPtr);
end;

if Result then
Exit;

Result := True;
TestPtr := BytePtr;
for Index := Low(ExpectedValues) to High(ExpectedValues) do
begin
if TestPtr^ <> ExpectedValues[Index] then
begin
Result := False;
Exit;
end;
Inc(TestPtr);
end;

PatchSize := Length(NewValues) * SizeOf(Byte);

if VirtualProtect(BytePtr, PatchSize, PAGE_EXECUTE_READWRITE, OldProtect) then
begin
try
TestPtr := BytePtr;
for Index := Low(NewValues) to High(NewValues) do
begin
TestPtr^ := NewValues[Index];
Inc(TestPtr);
end;
Result := True;
finally
Result := Result
and VirtualProtect(BytePtr, PatchSize, OldProtect, OldProtect)
and FlushInstructionCache(GetCurrentProcess, BytePtr, PatchSize);
end;
end;
end;

procedure PatchWinControl;
var
MethodAddress: Pointer;
begin
if not GetMethodAddress(WM_DRAWITEM, TWinControl, MethodAddress) then
begin
ShowMessage('Cannot find WM_DRAWITEM handler in TWinControl');
Exit;
end;
if (not PatchInstructionByte(MethodAddress, 13, $4, $14)) // release and package
and (not PatchInstructionByte(MethodAddress, 23, $4, $14)) then // debug
ShowMessage('Cannot patch WM_DRAWITEM');

if not GetMethodAddress(WM_COMPAREITEM, TWinControl, MethodAddress) then
begin
ShowMessage('Cannot find WM_COMPAREITEM handler in TWinControl');
Exit;
end;
if (not PatchInstructionByte(MethodAddress, 13, $04, $8)) // release and package
and (not PatchInstructionByte(MethodAddress, 23, $04, $8)) then // debug
ShowMessage('Cannot patch WM_COMPAREITEM handler');

if not GetMethodAddress(WM_DELETEITEM, TWinControl, MethodAddress) then
begin
ShowMessage('Cannot find WM_DELETEITEM handler in TWinControl');
Exit;
end;
if (not PatchInstructionByte(MethodAddress, 13, $04, $0C)) // release and package
and (not PatchInstructionByte(MethodAddress, 23, $04, $0C)) then // debug
ShowMessage('Cannot patch WM_DELETEITEM handler');

if not GetMethodAddress(WM_MEASUREITEM, TWinControl, MethodAddress) then
begin
ShowMessage('Cannot find WM_MEASUREITEM handler in TWinControl');
Exit;
end;
if (not PatchInstructionBytes(MethodAddress, 10, [$08, $8B], [$04, $90, $90, $90], [$04, $E8])) // release and package
and (not PatchInstructionBytes(MethodAddress, 20, [$08, $8B], [$04, $90, $90, $90], [$04, $E8])) then // debug
ShowMessage('Cannot patch WM_MEASUREITEM handler');
end;

{$ENDIF}

// end of "WMDrawItem fails under WOW64" patch
initialization
{$IFDEF VER150} // Delphi7
PatchWinControl;
{$ENDIF}

end.