PageControlタブの背景色 (ID:26187)

名前

ホームページ(ブログ、Twitterなど)のURL (省略可)

本文

>初歩的な質問です。
ホントに「初歩的な質問」？
>タブの背景色のさらに外側の色が気になります...
特注だね...

procedure TForm1.PageControl1Change(Sender: TObject);
begin
  PageControl1.Invalidate;
end;

procedure TForm1.FormCreate(Sender: TObject);
begin
  OldWinProc := PageControl1.WindowProc;
  PageControl1.WindowProc := NewWinProc;
end;

procedure ExtDrawTab(Canvas: TCanvas; R: TRect; S: string; Index: Integer);
const
  dr = 5;
  CL: array[0..7]of TColor = (clBlue, clRed, clFuchsia, clLime, clAqua, clYellow, clGreen, clInfobk);
var
  hR: HRGN;
begin
  with Canvas do begin
    Pen.Color := clAqua;
    hR := CreateRectRgn(R.Left, R.Top, R.Right, R.Bottom);
    SelectClipRgn(Handle, hR);
    RoundRect(R.Left, R.Top, R.Right, R.Bottom + 30, dr, dr);
    SelectClipRgn(Handle, 0);
    DeleteObject(hR);
    Pen.Color := clGray;
    OffsetRect(R, 1, 1);
    hR := CreateRectRgn(R.Right -dr div 2, R.Top, R.Right, R.Bottom);
    SelectClipRgn(Handle, hR);
    RoundRect(R.Left, R.Top, R.Right, R.Bottom + 30, dr, dr);
    SelectClipRgn(Handle, 0);
    DeleteObject(hR);
    Canvas.Brush.Color := CL[Index];
    Canvas.FillRect(R);
    InflateRect(R, -2, -2);
    TextRect(R, R.Left + 2, R.Top + 1, S);
  end;
end;

type
  _TPageControl = class(TPageControl)
  end;

procedure ExtDrawPageControl(PageCtrl: TPageControl);
var
  I, Y: Integer;
  R: TRect;
begin
  with PageCtrl, Canvas do begin
    DoubleBuffered := True;
    Canvas.Font := PageCtrl.Font;
    Canvas.Brush.Color := $ffaa99; // TForm(PageCtrl).Color;
    R := ClientRect;
    FillRect(R);
    R := _TPageControl(PageCtrl).DisplayRect;
    InflateRect(R, 4, 4);
    Frame3D(Canvas, R, clAqua, clBlue, 1);
    Y := R.Top;
    Font.Color := clGray;
    for I := PageCount - 1 downto 0 do begin
      if I <> ActivePageIndex then begin
        R := TabRect(I);
        R.Left := R.Left - 2;
        ExtDrawTab(Canvas, R, Pages[I].Caption, I);
        Pen.Color := clAqua;
        MoveTo(R.Left, Y - 1);
        LineTo(R.Right + 1, Y - 1);
      end;
    end;
    if (ActivePageIndex >= 0) then begin
      Font.Color := clBlack;
      Font.Style := [fsBold];
      R := TabRect(ActivePageIndex);
      R.Top := R.Top - 2;
      R.Left := R.Left - 2;
      R.Bottom := R.Bottom + 1;
      ExtDrawTab(Canvas, R, Pages[ActivePageIndex].Caption, ActivePageIndex);
    end;
  end;
end;

procedure TForm1.NewWinProc(var Msg: TMessage);
var
  ps: TPaintStruct;
begin
  if Msg.Msg = WM_PAINT then begin
    BeginPaint(PageControl1.Handle, ps);
    EndPaint(PageControl1.Handle, ps);
    Msg.Result := 0;
    ExtDrawPageControl(PageControl1);
  end
  else
    OldWinProc(Msg);
end;

←解決時は質問者本人がここをチェックしてください。

戻る