Delphi7 TTabControl 64ビットOSでOwnerDRawが効かない

解決

くまお 2022-12-27 16:32:54 No: 150717

Delphi7のTTabControlのOwnerDrawを32ビットでは、問題なく表示するが、64ビットOSでは消えてしまう。

OwnerDrawをTRue;

procedure TabContorol1.DrawTab(Control: TCustomTabControl;
  TabIndex: Integer; const Rect: TRect; Active: Boolean);
var
  R: TRect;
begin
  R := Rect;
  with Control.Canvas do begin
   if Active then begin
    Brush.Color := $00F7EEB5;
    Font.Color := clBlue;
    Font.Style := [fsBold];
    InflateRect(R, -1, -1);
   end else begin
    Brush.Color := clWhite;
    Font.Color := clBlack;
    Font.Style := [];
    OffsetRect(R, 0, 2);
   end;
   FillRect(R);
   TextOut(Rect.Left+4, Rect.Top+4, TTabControl(Control).Tabs[TabIndex]);
  end;
end;

これが、32ビットOSであると問題なく動く。
６４ビットOSだとTABが真っ白（＝ω＝；）
なんででしょう？

igy 2022-12-27 22:55:55 No: 150718

TTabControl ではなく、TPageControl ですが、
以前、エンバカデロのフォーラムに
TPageControl OnDrawTab and Win64
https://forums.embarcadero.com/thread.jspa?messageID=292598
があり、そこに書かれていた VCLFixesをプロジェクトに追加することで、描画できてた気がしますが、
今は見られないですね。

検索すると、
http://www.codenewsfast.com/cnf/thread//permalink.thr-ng1942q2284
にあるような・・

くまお 2022-12-28 09:33:40 No: 150719

igyさんありがとうございます。

VCLFixesをプロジェクトに含めているのですが、まったく変わらないのです（＝ω＝；）
単に、プロジェクトに含めてコンパイルするだけでは交換がないのでしょうか？？
以下が、VCLFixes.pasの内容です。

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
{$IF defined(VER150) or defined(VER170)} // Delphi 7 , 2005
{$IFEND}
end.

igy 2022-12-28 10:09:50 No: 150720

こちらで試したかぎりでは、
PageControl、TabControlの両方とも、プロジェクトにVCLFixesを追加するだけで、
描画されました。(Delphi 7, Windows 10 64bit)

くまお 2022-12-28 12:28:13 No: 150721

プロジェクトファイルの

uses
  ShareMem,
  Forms,
  Windows,
  SysUtils,

  UnitPrint2 in 'UnitPrint2.pas' {PForm1},
  UnitRefMNT in 'UnitRefMNT.pas' {refMNT},
  UnitCommonCtrl in 'UnitCommonCtrl.pas',
  VCLFixes in 'VCLFixes.pas';

のような具合で追加しただけですか？
Mutex作ってるのがダメなのかなぁ？？

くまお 2022-12-28 12:44:18 No: 150722

Mutexは、外しても表示されない・・・・無関係っぽいなぁ。
VCLFixes inを頭に持ってきてもダメだし（＝ω＝；）
どこが問題なのか・・・
テストしてるのが、６４ビットサーバーOSなのが問題なのかと思い、Windows10 64ビットで試してもダメ・・・

igy 2022-12-28 13:05:23 No: 150723

> VCLFixes in 'VCLFixes.pas';
>
>のような具合で追加しただけですか？

はい。IDEのメニューから「プロジェクトに追加」（だったかな？）で追加しました。

新規プロジェクトで、フォームにPageControl、TabControlを追加しただけのもので、
試してました。

新規プロジェクトでTabControlだけを置いて試した場合でも、同じ結果になりますか？

au 2022-12-28 13:47:00 No: 150724

検索して出てくるコードだと initialization の中でPatchWinControl; を呼ぶようになってますが、貼ってあるコードだと、initializationの中が空になってます。

くまお 2022-12-29 22:54:28 No: 150726

igyさん

もともとTTabControlしか使っていないんですよねー（＝ω＝；）

くまお 2022-12-29 22:56:00 No: 150727

auさん

PatchWinControl;
を呼んだら、なんのことなく表示されるようになりました。

igyさん、auさん本当にありがとうございました。
助かりました。