2012/10/29

如何改變 TPageControl 的 Tab Title Font + BG Color

作者：吳祐賓 (2023/08/31 更新)




文章來源：tabsheet フォン変更   by www

雖然是日文的內容，可是還蠻容易理解的。

BCB6 和 Delphi 7 的 PageControl.OwnerDraw 為 True 時，但在 Win7 64bit 下會出現 Tab Title及 OnDrawTab 無功能的情況，在文末有解決方法！

以下是節錄內容：


 1
 2
 3
 4
 5
 6
 7
 8
 9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
//---------------------------------------------------------------------------
void __fastcall TForm1::PageControl1DrawTab(TCustomTabControl *Control,
      int TabIndex, const TRect &Rect, bool Active)
{
    //  描画を行うタブの番号（TabIndex）から
    //  本来のタブに記載される文字列(TabSheet の Caption）を取得
    AnsiString  TabTitle = PageControl1->Pages[TabIndex]->Caption;
 
    //  タブに現在のフォント（PageControl のFont）でタブに記載する
    //  文字を書いた場合の幅と高さを取得
    int TitleWidth = Control->Canvas->TextWidth(TabTitle);
    int TitleHeight = Control->Canvas->TextHeight(TabTitle);
 
    //  描画領域を背景色で塗りつぶし
    //  Control->Canvas->Brush->Style = bsSolid;
    //  Control->Canvas->Brush->Color = clBlue;
    Control->Canvas->FillRect(Rect);
 
    //  描画を行うタブが、アクティブかどうかでフォントの色を変更
    if(Active){
        //  アクティブなら赤を指定
        Control->Canvas->Font->Color = clRed;
    }
    else {
        //  そうでなければ黒を指定
        Control->Canvas->Font->Color = clBlack;
    }
 
    //  描画の座標領域は、引数 TRect に存在
    //
    //  タブの中心に表示する場合は、
    //    全体の幅から、文字の幅を引くと、余白の幅が求められ
    //    文字を書く位置を余白の幅の半分にすると、中心に描画される
    int LeftPos = Rect.left + (Rect.Width()  - TitleWidth ) / 2;
    int TopPos  = Rect.top  + (Rect.Height() - TitleHeight) / 2;
 
    //  アクティブでない場合描画位置を２ドット程下に下げる
    //  指定しないと見てくれがなんか悪い
    if(Active == false){
        TopPos+=2;
    }
 
    //  テキストの描画
    Control->Canvas->TextOutA(LeftPos,TopPos,TabTitle);
}
//---------------------------------------------------------------------------


TPageControl OnDrawTab and Win64 
  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
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.

 

 

See also

 

3 則留言:

  1. David Hou2023/8/31 上午10:14

    大大你好，我使用BCB6，將你整段程式碼copy到PageControl1DrawTab內，程式執行如常，但卻無作用。debug之，發現是PageControl1DrawTab事件根本無作用。請問為何? 謝謝

    回覆刪除
    回覆
    1. Eden2023/8/31 上午11:14

      PageControl.OwnerDraw 為 True 時才會有作用，擷圖已更新在文章頂部。

      刪除
    2. David Hou2023/8/31 下午3:24

      GREAT! 可以了，感謝^^

      刪除

訂閱： 張貼留言 (Atom)