2012/10/29

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


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

雖然是日文的內容,可是還蠻容易理解的
此外,Delphi7裡面的PageControl在Win7 64bit下有bug 當設定 OwnerDraw 時,Tab Title及OnDrawTab會無功能,在文末有解決方法!

以下是節錄內容:

//---------------------------------------------------------------------------
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;

    //  アクティブでない場合描画位置を2ドット程下に下げる
    //  指定しないと見てくれがなんか悪い
    if(Active == false){
        TopPos+=2;
    }

    //  テキストの描画
    Control->Canvas->TextOutA(LeftPos,TopPos,TabTitle);
}
//---------------------------------------------------------------------------


TPageControl OnDrawTab and Win64
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.








好啦…我知道你們的重點不在這裡啦…

沒有留言:

張貼留言

JSON Parse in Delphi XE (01)

在 Delphi.ktop 的主題中,看到了【 JSON求教 】這一篇 如果在 XE 裡面要實現,是不是也是這麼簡單? 想到了,就開始來實作吧!