Форум: "Прочее";
Текущий архив: 2008.06.29;
Скачать: [xml.tar.bz2];

Вниз

PageControl   Найти похожие ветки 

← →
Германн ©   (2008-05-16 02:21) [40]

> Игорь Шевченко ©   (15.05.08 23:03) [34]
>
> DVM ©   (15.05.08 22:52) [33]
>
> Эстетствую :)
>

В отпуске что-ли?
Вспомни цитату из Швейка.
:)

---

← →
Style ©   (2008-05-16 09:37) [41]

Игорь вот теперь похоже на [5] ;)


unit u_pcpainter;

interface

uses
 Windows, Messages, SysUtils, Variants, Classes, Graphics, Controls,
 ComCtrls;

type
 TPageControlPainter = class
 private
   FPageControl: TPageControl;
   FWindowProc: TWndMethod;
   FCanvas: TCanvas;
   fhTab,FMx,FMy: integer;
   procedure SetCanvas(const Value: TCanvas);
   procedure DrawGradient(ACanvas: TCanvas; Rect: TRect;
     Horicontal: Boolean; Colors: array of TColor);
 protected
   procedure CustomWindowProc(var Message: TMessage); virtual;
   procedure CustomPaint; virtual;
   procedure PaintTabs(Invalidate: boolean); virtual;
 public
   constructor Create(APageControl: TPageControl);
   destructor Destroy; override;

   property Canvas: TCanvas read FCanvas write SetCanvas;
 end;

implementation

const
 PCP_BORDERCOLOR        = $a68c52;
 PCP_TABBORDERCOLOR     = clSilver;
 PCP_ACTIVETABGRADUP1   = $ccb893;
 PCP_ACTIVETABGRADUP2   = $af925b;
 PCP_ACTIVETABGRADDOWN1 = $8a6a24;
 PCP_ACTIVETABGRADDOWN2 = $A28649;
 PCP_HOVERTABGRADUP2   = $f7f5ee;
 PCP_HOVERTABGRADDOWN1 = $ebe9d4;
 PCP_HOVERTABGRADDOWN2 = $e2dfc3;

type
 TXControl = class(TControl);
 TXWinControl = class(TWinControl);

{ TPageControlPainter }

constructor TPageControlPainter.Create(APageControl: TPageControl);
begin
 inherited Create;
 FPageControl := APageControl;
 FWindowProc := FPageControl.WindowProc;
 FPageControl.WindowProc := CustomWindowProc;
 FCanvas := FPageControl.Canvas;
 FPageControl.Style := tsButtons;
end;

procedure TPageControlPainter.CustomPaint;
begin
   Canvas.Pen.Color := PCP_BORDERCOLOR;
   Canvas.Rectangle(
   FPageControl.ClientRect.Left,
   FPageControl.TabRect(0).Bottom-1,
   FPageControl.ClientRect.Right,
   FPageControl.ClientRect.Bottom);
end;

procedure TPageControlPainter.DrawGradient(ACanvas: TCanvas; Rect: TRect;
  Horicontal: Boolean; Colors: array of TColor);
type
  RGBArray = array[0..2] of Byte;
var
  x, y, z, stelle, mx, bis, faColorsh, mass: Integer;
  Faktor: double;
  A: RGBArray;
  B: array of RGBArray;
  merkw: integer;
  merks: TPenStyle;
  merkp: TColor;
begin
  mx := High(Colors);
  if mx > 0 then
  begin
    if Horicontal then
      mass := Rect.Right - Rect.Left
    else
      mass := Rect.Bottom - Rect.Top;
    SetLength(b, mx + 1);
    for x := 0 to mx do
    begin
      Colors[x] := ColorToRGB(Colors[x]);
      b[x][0] := GetRValue(Colors[x]);
      b[x][1] := GetGValue(Colors[x]);
      b[x][2] := GetBValue(Colors[x]);
    end;
    merkw := ACanvas.Pen.Width;
    merks := ACanvas.Pen.Style;
    merkp := ACanvas.Pen.Color;
    ACanvas.Pen.Width := 1;
    ACanvas.Pen.Style := psSolid;
    faColorsh := Round(mass / mx);
    for y := 0 to mx - 1 do
    begin
      if y = mx - 1 then
        bis := mass - y * faColorsh - 1
      else
        bis := faColorsh;
      for x := 0 to bis do
      begin
        Stelle := x + y * faColorsh;
        faktor := x / bis;
        for z := 0 to 3 do
          a[z] := Trunc(b[y][z] + ((b[y + 1][z] - b[y][z]) * Faktor));
        ACanvas.Pen.Color := RGB(a[0], a[1], a[2]);
        if Horicontal then
        begin
          ACanvas.MoveTo(Rect.Left + Stelle, Rect.Top);
          ACanvas.LineTo(Rect.Left + Stelle, Rect.Bottom);
        end
        else
        begin
          ACanvas.MoveTo(Rect.Left, Rect.Top + Stelle);
          ACanvas.LineTo(Rect.Right, Rect.Top + Stelle);
        end;
      end;
    end;
    b := nil;
    ACanvas.Pen.Width := merkw;
    ACanvas.Pen.Style := merks;
    ACanvas.Pen.Color := merkp;
  end;
end;

procedure TPageControlPainter.PaintTabs(Invalidate: boolean);
var
 i: integer;
 rct: tRect;

 procedure localpaintTab(color: TColor);
 begin
   rct := FPageControl.TabRect(i);
   rct.Left  := rct.Left - 2;
   rct.Right := rct.Right + 2;
   Canvas.Pen.Color := Color;
   FPageControl.Canvas.Rectangle(rct);
   if Invalidate then
     FPageControl.Pages[i].Invalidate;
 end;

 procedure doubleGrad(c1,c2,c3,c4: tColor);
 begin
   InflateRect(rct,-1,-1);
   DrawGradient(Canvas,Rect(rct.Left,rct.Top,rct.Right,rct.Bottom-((rct.Bottom-rct.Top) div 2)+2),false,[c1,c2]);
   DrawGradient(Canvas,Rect(rct.Left,rct.Top+((rct.Bottom-rct.Top) div 2)+2,rct.Right,rct.Bottom),false,[c3,c4]);
 end;
begin
 SetBkMode(Canvas.Handle,TRANSPARENT);
 for i := 0 to FPageControl.PageCount-1 do
 begin
   if i <> FPageControl.ActivePageIndex then
   begin
    localpaintTab(PCP_TABBORDERCOLOR);
    if fhTab = i then
      doublegrad(PCP_HOVERTABGRADUP2, clWhite,
              PCP_HOVERTABGRADDOWN1, PCP_HOVERTABGRADDOWN2)
    else
      doublegrad(clWhite,clwhite,clwhite, PCP_HOVERTABGRADUP2);

   Canvas.Font.Color := clBlack;
   SetBkMode(Canvas.Handle,TRANSPARENT);
   DrawText(Canvas.Handle, PChar(FPageControl.Pages[i].Caption), Length(FPageControl.Pages[i].Caption), Rct, DT_SINGLELINE or DT_VCENTER or DT_CENTER);

   end else continue;
 end;
 i := FPageControl.ActivePageIndex;
 localpaintTab(PCP_BORDERCOLOR);
 doublegrad(PCP_ACTIVETABGRADUP1, PCP_ACTIVETABGRADUP2,
            PCP_ACTIVETABGRADDOWN1, PCP_ACTIVETABGRADDOWN2);

 DrawGradient(Canvas,Rect(0,rct.Bottom,FpageControl.Width,rct.Bottom+4),false,[PCP_ACTIVETABGRADDOWN2,PCP_BORDERCOLOR]);
 Canvas.Font.Color := clWhite;
 SetBkMode(Canvas.Handle,TRANSPARENT);
 DrawText(Canvas.Handle, PChar(FPageControl.Pages[i].Caption), Length(FPageControl.Pages[i].Caption), Rct, DT_SINGLELINE or DT_VCENTER or DT_CENTER);

end;

procedure TPageControlPainter.CustomWindowProc(var Message: TMessage);
var
 i: integer;
 pt: TPoint;
begin
 FWindowProc(Message);
 if(Message.Msg = WM_NCHITTEST) then
 begin
   pt := Point(LOWORD(Message.LParam),HIWORD(Message.LParam));
   ScreenToClient(FPageControl.Handle,pt);
   fMx := pt.X;
   fMy := pt.Y;
   i := fhTab;
   fhTab := -1;
   fhTab := FPageControl.IndexOfTabAt(fMx,fMy);
   if(fhTab <> i) then
     PaintTabs(false);
 end;
 if(Message.Msg = WM_NCPAINT ) or
   (Message.Msg = WM_PAINT   ) then
 begin
   CustomPaint;
   PaintTabs(true);
 end else
end;

destructor TPageControlPainter.Destroy;
begin
 FPageControl.WindowProc := FWindowProc;
 inherited;
end;

procedure TPageControlPainter.SetCanvas(const Value: TCanvas);
begin
 FCanvas := Value;
end;

end.


---

← →
Игорь Шевченко ©   (2008-05-16 10:06) [42]

Style ©   (16.05.08 09:37) [41]

Спасибо, похоже! :) Только мигает со страшной силой :) Но как канва, вполне может подойти

---

← →
Style ©   (2008-05-16 10:23) [43]

Мигает из-за перерисовки страницы.

Во первых надо еще в Create паинтера добавить

FPageControl.OwnerDraw := true;

потом

procedure localpaintTab(color: TColor);
begin
  rct := FPageControl.TabRect(i);
  rct.Left  := rct.Left - 2;
  rct.Right := rct.Right + 2;
  Canvas.Pen.Color := Color;
  FPageControl.Canvas.Rectangle(rct);
//   Вот это убрать if Invalidate then  
//   Вот это убрать   FPageControl.Pages[i].Invalidate;
end;

и добавить

begin
 if FPageControl.ActivePageIndex > -1 then
   if Invalidate then FPageControl.Pages[FPageControl.ActivePageIndex].Invalidate;

перед SetBkMode(Canvas.Handle,TRANSPARENT);

Да и вообще хотелось сделать вот так.

procedure TPageControlPainter.CustomWindowProc(var Message: TMessage);
var
 i: integer;
 pt: TPoint;
begin
 if(Message.Msg = WM_NCHITTEST) then
 begin
   FWindowProc(Message);
   pt := Point(LOWORD(Message.LParam),HIWORD(Message.LParam));
   ScreenToClient(FPageControl.Handle,pt);
   fMx := pt.X;
   fMy := pt.Y;
   i := fhTab;
   fhTab := -1;
   fhTab := FPageControl.IndexOfTabAt(fMx,fMy);
   if(fhTab <> i) then
     PaintTabs(false);
 end;
 if(Message.Msg = WM_NCPAINT ) or
   (Message.Msg = WM_PAINT   ) then
 begin
   CustomPaint;
   PaintTabs(true);
 end else
   FWindowProc(Message);
end;

т.е. чтобы вообще не передавать старому WindowProc
события WM_PAINT и WM_NCPAINT
а рисовать самому.
   CustomPaint;
   PaintTabs(true);

Но так почему-то, я пока не понял, все трясется вообще и постоянно моргает. Возможно надо обработать еще WM_ERASEBKGND.

---

← →
Игорь Шевченко ©   (2008-05-16 10:39) [44]

Style ©   (16.05.08 10:23) [43]

Поменял. Трясется также. При тряске (например, при изменении размера) видны старые нарисованные следы (например, рамка фокуса и 3D-бордюр от табов). Если при изменении размера возникает скроллер табов (две кнопки со стрелками), то их фон не перерисовывается и остается то, что было до ресайза.
Но в любом случае - спасибо.

---

← →
Style ©   (2008-05-16 10:48) [45]

> При тряске (например, при изменении размера) видны старые
> нарисованные следы (например, рамка фокуса и 3D-бордюр от
> табов).


Во-во я про это и писал что пока не понял почему вообще все трясется если не передавать WindowProc. И рисую поверх старого :(


> Если при изменении размера возникает скроллер табов (две
> кнопки со стрелками), то их фон не перерисовывается и остается
> то, что было до ресайза.


На счет кнопок я тоже думал, но пока до них не дошел.

Вообще по-хорошему надо ограничить регион ClipingRect только областью тела табшита, а все Табы не только рисовать самому, но и обрабатывать нажатия мыши, переносы на други строки и соотвественно размеры табов делать свои ,а  не те к которые TabCtrl_GetItemRect(Handle, Index, Result); возвращает
и не зависимо от Style самого PageControl"а

---

← →
Игорь Шевченко ©   (2008-05-16 11:01) [46]

Style ©   (16.05.08 10:48) [45]


> обрабатывать нажатия мыши, переносы на други строки и соотвественно
> размеры табов делать свои ,а  не те к которые TabCtrl_GetItemRect(Handle,
>  Index, Result); возвращает


в Wine надо поглядеть, как оно там устроено,они ж старались полной совместимости по внешнему виду добиться.

---

← →
Style ©   (2008-05-16 11:22) [47]

ну да собсно это же comctl32.dll
а в Wine эта библиотека должна быть реализована.

---

Страницы: 1 2 вся ветка

Форум: "Прочее";
Текущий архив: 2008.06.29;
Скачать: [xml.tar.bz2];

Наверх

Память: 0.56 MB
Время: 0.041 c