tabs.pas

这是不可多得的源代码

  TTabList(FTabs).Tabs := Self;
  InitBitmaps;

  CreateScroller;

  FTabIndex := -1;
  FFirstIndex := 0;
  FVisibleTabs := 0;  { set by draw routine }
  FStartMargin := 5;
  FEndMargin := 5;

  { initialize default values }
  FSelectedColor := clBtnFace;
  FUnselectedColor := clWindow;
  FBackgroundColor := clBtnFace;
  FDitherBackground := True;
  CreateBrushPattern(BrushBitmap);
  FAutoScroll := True;
  FStyle := tsStandard;
  FOwnerDrawHeight := 20;

  ParentFont := False;
  Font.Name := DefFontData.Name;
  Font.Height := DefFontData.Height;
  Font.Style := [];

  { create the edge bitmaps }
  CreateEdgeParts;
end;

procedure TTabSet.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
  with Params.WindowClass do
    style := style and not (CS_VREDRAW or CS_HREDRAW);
end;

procedure TTabSet.CreateScroller;
begin
  FScroller := TScroller.Create(Self);
  with Scroller do
  begin
    Parent := Self;
    Top := 3;
    Min := 0;
    Max := 0;
    Position := 0;
    Visible := False;
    OnClick := ScrollClick;
  end;
end;

procedure TTabSet.InitBitmaps;
begin
  MemBitmap := TBitmap.Create;
  BrushBitmap := TBitmap.Create;
end;

destructor TTabSet.Destroy;
begin
  FTabs.Free;
  TabPositions.Free;
  DoneBitmaps;
  inherited Destroy;
end;

procedure TTabSet.DoneBitmaps;
begin
  MemBitmap.Free;
  BrushBitmap.Free;
  ImageList.Free;
end;

procedure TTabSet.ScrollClick(Sender: TObject);
begin
  FirstIndex := TScroller(Sender).Position;
end;

{ cache the tab position data, and return number of visible tabs }
function TTabSet.CalcTabPositions(Start, Stop: Integer; Canvas: TCanvas;
  First: Integer): Integer;
var
  Index: Integer;
  TabPos: TTabPos;
begin
  TabPositions.Count := 0;  { erase all previously cached data }
  Index := First;
  while (Start < Stop) and (Index < Tabs.Count) do
    with Canvas do
    begin
      TabPos.StartPos := Start;
      TabPos.Size := ItemWidth(Index);
      Inc(Start, TabPos.Size + EdgeWidth);    { next usable position }

      if Start <= Stop then
      begin
        TabPositions.Add(Pointer(TabPos));    { add to list }
        Inc(Index);
      end;
    end;
  Result := Index - First;
end;

function TTabSet.ItemAtPos(Pos: TPoint): Integer;
var
  TabPos: TTabPos;
  I: Integer;
begin
  Result := -1;
  if (Pos.Y < 0) or (Pos.Y > ClientHeight) then Exit;
  for I := 0 to TabPositions.Count - 1 do
  begin
    Pointer(TabPos) := TabPositions[I];
    if (Pos.X >= TabPos.StartPos) and (Pos.X <= TabPos.StartPos + TabPos.Size) then
    begin
      Result := I;
      Exit;
    end;
  end;
end;

function TTabSet.ItemRect(Item: Integer): TRect;
var
  TabPos: TTabPos;
begin
  if (TabPositions.Count > 0) and (Item >= 0) and (Item < TabPositions.Count) then
  begin
    Pointer(TabPos) := TabPositions[Item];
    Result := Rect(TabPos.StartPos, 0, TabPos.StartPos + TabPos.Size, FTabHeight);
    InflateRect(Result, 1, -2);
  end
  else
    Result := Rect(0, 0, 0, 0);
end;

procedure TTabSet.Paint;
var
  TabStart, LastTabPos: Integer;
  TabPos: TTabPos;
  Tab: Integer;
  Leading: TEdgeType;
  Trailing: TEdgeType;
  isFirst, isLast, isSelected, isPrevSelected: Boolean;
  R: TRect;
begin
  if not HandleAllocated then Exit;

  { Set the size of the off-screen bitmap.  Make sure that it is tall enough to
    display the entire tab, even if the screen won't display it all.  This is
    required to avoid problems with using FloodFill. }
  MemBitmap.Width := ClientWidth;
  if ClientHeight < FTabHeight + 5 then MemBitmap.Height := FTabHeight + 5
  else MemBitmap.Height := ClientHeight;

  MemBitmap.Canvas.Font := Self.Canvas.Font;

  TabStart := StartMargin + EdgeWidth;        { where does first text appear? }
  LastTabPos := Width - EndMargin;            { tabs draw until this position }
  Scroller.Left := Width - Scroller.Width - 2;

  { do initial calculations for how many tabs are visible }
  FVisibleTabs := CalcTabPositions(TabStart, LastTabPos, MemBitmap.Canvas,
    FirstIndex);

  { enable the scroller if FAutoScroll = True and not all tabs are visible }
  if AutoScroll and (FVisibleTabs < Tabs.Count) then
  begin
    Dec(LastTabPos, Scroller.Width - 4);
    { recalc the tab positions }
    FVisibleTabs := CalcTabPositions(TabStart, LastTabPos, MemBitmap.Canvas,
      FirstIndex);

    { set the scroller's range }
    Scroller.Visible := True;
    ShowWindow(Scroller.Handle, SW_SHOW);
    Scroller.Min := 0;
    Scroller.Max := Tabs.Count - VisibleTabs;
    Scroller.Position := FirstIndex;
  end
  else
    if VisibleTabs >= Tabs.Count then
    begin
      Scroller.Visible := False;
      ShowWindow(Scroller.Handle, SW_HIDE);
    end;

  if FDoFix then
  begin
    FixTabPos;
    FVisibleTabs := CalcTabPositions(TabStart, LastTabPos, MemBitmap.Canvas,
      FirstIndex);
  end;
  FDoFix := False;

  { draw background of tab area }
  with MemBitmap.Canvas do
  begin
    Brush.Bitmap := BrushBitmap;
    if ThemeServices.ThemesEnabled and ParentBackground then
      Perform(WM_ERASEBKGND, MemBitmap.Canvas.Handle, 0)
    else
      FillRect(Rect(0, 0, MemBitmap.Width, MemBitmap.Height));

    // draw top edget
    // XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
    //  \               /--------------/
    //   \             /\             /
    //    \___________/  \___________/
    if not ThemeServices.ThemesEnabled then
    begin
      Pen.Width := 1;
      Pen.Color := clBtnShadow;
      MoveTo(0, 0);
      LineTo(MemBitmap.Width + 1, 0);
    end;

    if not FSoftTop then
    begin
      Pen.Color := clWindowFrame;
      MoveTo(0, 1);
      LineTo(MemBitmap.Width + 1, 1);
    end;
  end;

  for Tab := 0 to TabPositions.Count - 1 do
  begin
    Pointer(TabPos) := TabPositions[Tab];

    isFirst := Tab = 0;
    isLast := Tab = VisibleTabs - 1;
    isSelected := Tab + FirstIndex = TabIndex;
    isPrevSelected := (Tab + FirstIndex) - 1 = TabIndex;

    { Rule: every tab paints its leading edge, only the last tab paints a
      trailing edge }
    Trailing := etNone;

    if isLast then
    begin
      if isSelected then Trailing := etLastIsSel
      else Trailing := etLastNotSel;
    end;

    if isFirst then
    begin
      if isSelected then Leading := etFirstIsSel
      else Leading := etFirstNotSel;
    end
    else  { not first }
    begin
      if isPrevSelected then Leading := etSelToNotSel
      else
        if isSelected then Leading := etNotSelToSel
        else Leading := etNotSelToNotSel;
    end;

    { draw leading edge }
    // |XXXX|================================
    // | X  |             /--------------/
    // |  X |            /\             /
    // |   X|___________/  \___________/
    if Leading <> etNone then
      PaintEdge(TabPos.StartPos - EdgeWidth, 0, FTabHeight - 1, Leading);

    { set up the canvas }
    R := Rect(TabPos.StartPos, 0, TabPos.StartPos + TabPos.Size, FTabHeight);
    with MemBitmap.Canvas do
    begin
      if isSelected then Brush.Color := SelectedColor
      else Brush.Color := UnselectedColor;
      ExtTextOut(Handle, TabPos.StartPos, 2, ETO_OPAQUE, @R,
        nil, 0, nil);
    end;

    { restore font for drawing the text }
    MemBitmap.Canvas.Font := Self.Canvas.Font;

    { Owner }
    if (FStyle = tsOwnerDraw) then
      DrawTab(MemBitmap.Canvas, R, Tab + FirstIndex, isSelected)
    else
    begin
      with MemBitmap.Canvas do
      begin
        Inc(R.Top, 2);
        DrawText(Handle, PChar(Tabs[Tab + FirstIndex]),
          Length(Tabs[Tab + FirstIndex]), R, DT_CENTER);
      end;
    end;

    { draw trailing edge  }
    // ===============|XXXX|=================
    //  \             |  XX|-------------/
    //   \            | XX |            /
    //    \___________|X  X|___________/
    // or
    // ==============================|XXXX|==
    //  \               /------------|XXX |
    //   \             /\            | X  |
    //    \___________/  \___________|X   |
    if Trailing <> etNone then
      PaintEdge(TabPos.StartPos + TabPos.Size, 0, FTabHeight - 1, Trailing);

    { draw connecting lines above and below the text }
    // ====================================
    //  \               /-XXXXXXXXXXX--/
    //   \             /\             /
    //    \XXXXXXXXXXX/  \XXXXXXXXXXX/
    with MemBitmap.Canvas do
    begin
      Pen.Color := clWindowFrame;
      MoveTo(TabPos.StartPos, FTabHeight - 1);
      LineTo(TabPos.StartPos + TabPos.Size, FTabHeight - 1);

      if isSelected then
      begin
        Pen.Color := clBtnShadow;
        MoveTo(TabPos.StartPos, FTabHeight - 2);
        LineTo(TabPos.StartPos + TabPos.Size + 1, FTabHeight - 2);
      end
      else
      begin
        if SoftTop then
          Pen.Color := BackgroundColor
        else
          Pen.Color := clWindowFrame;
        MoveTo(TabPos.StartPos, 1);
        LineTo(TabPos.StartPos + TabPos.Size, 1);

        Pen.Color := clBtnShadow;
        MoveTo(TabPos.StartPos, 0);
        LineTo(TabPos.StartPos + TabPos.Size + 1, 0);
      end;
    end;
  end;

  { draw onto the screen }
  Canvas.Draw(0, 0, MemBitmap);
end;

procedure TTabSet.CreateEdgeParts;
var
  H: Integer;
  Working: TBitmap;
  EdgePart: TEdgePart;
  MaskColor: TColor;

  procedure DrawUL(Canvas: TCanvas);
  begin
    with Canvas do
    begin
      Pen.Color := clBtnShadow;
      PolyLine([Point(0, 0), Point(EdgeWidth + 1, 0)]);

      Pen.Color := UnselectedColor;
      Brush.Color := UnselectedColor;
      Polygon([Point(3, 1), Point(EdgeWidth - 1, H), Point(EdgeWidth, H),
        Point(EdgeWidth, 1), Point(3, 1)]);

      if SoftTop then
      begin
        Pen.Color := BackgroundColor;
        PolyLine([Point(4, 1), Point(EdgeWidth + 1, 1)]);
        Pen.Color := clWindowFrame;
        PolyLine([Point(3, 1), Point(EdgeWidth - 1, H), Point(EdgeWidth, H)]);
      end
      else
      begin
        Pen.Color := clWindowFrame;
        PolyLine([Point(0, 1), Point(EdgeWidth + 1, 1), Point(3, 1),
          Point(EdgeWidth - 1, H), Point(EdgeWidth, H)]);
      end;
      (*Pen.Color := clWindowFrame;
      if SoftTop then
        PolyLine([{Point(0, 1),} Point(EdgeWidth + 1, 1), Point(3, 1),
          Point(EdgeWidth - 1, H), Point(EdgeWidth, H)])
      else
        PolyLine([Point(0, 1), Point(EdgeWidth + 1, 1), Point(3, 1),
          Point(EdgeWidth - 1, H), Point(EdgeWidth, H)]);*)
    end;
  end;

  procedure DrawSL(Canvas: TCanvas);
  begin
    with Canvas do
    begin
      Pen.Color := SelectedColor;
      Brush.Color := SelectedColor;
      Polygon([Point(3, 0), Point(EdgeWidth - 1, H), Point(EdgeWidth, H),
        Point(EdgeWidth, 0), Point(3, 0)]);

      Pen.Color := clBtnShadow;
      PolyLine([Point(0, 0), Point(4, 0)]);

      Pen.Color := clBtnHighlight;
      PolyLine([Point(4, 1), Point(EdgeWidth, H + 1)]);

      Pen.Color := clWindowFrame;
      if SoftTop then
        PolyLine([{Point(0, 1),} Point(3, 1), Point(EdgeWidth - 1, H),
          Point(EdgeWidth, H)])
      else
        PolyLine([Point(0, 1), Point(3, 1), Point(EdgeWidth - 1, H),
          Point(EdgeWidth, H)]);
    end;
  end;

  procedure DrawUR(Canvas: TCanvas);
  begin
    with Canvas do
    begin
      Pen.Color := clBtnShadow;
      PolyLine([Point(-1, 0), Point(EdgeWidth + 1, 0)]);

      Pen.Color := UnselectedColor;
      Brush.Color := UnselectedColor;
      Polygon([Point(EdgeWidth - 3, 1), Point(1, H), Point(0, H),
        Point(0, 1), Point(EdgeWidth - 3, 1)]);

      { workaround for bug in S3 driver }
      Pen.Color := clBtnShadow;
      PolyLine([Point(-1, 0), Point(EdgeWidth + 1, 0)]);

      if SoftTop then
      begin
        Pen.Color := BackgroundColor;
        PolyLine([Point(0, 1), Point(EdgeWidth - 1, 1)]);
        Pen.Color := clWindowFrame;
        PolyLine([Point(EdgeWidth - 2, 1), Point(2, H), Point(-1, H)]);
      end
      else
      begin
        Pen.Color := clWindowFrame;
        PolyLine([Point(0, 1), Point(EdgeWidth + 1, 1), Point(EdgeWidth - 2, 1),
          Point(2, H), Point(-1, H)]);
      end;
      (*Pen.Color := clWindowFrame;
      if SoftTop then
        PolyLine([Point(0, 1), {Point(EdgeWidth + 1, 1),} Point(EdgeWidth - 2, 1),
          Point(2, H), Point(-1, H)])
      else
        PolyLine([Point(0, 1), Point(EdgeWidth + 1, 1), Point(EdgeWidth - 2, 1),
          Point(2, H), Point(-1, H)])*)
    end;
  end;

  procedure DrawSR(Canvas: TCanvas);
  begin
    with Canvas do
    begin
      Pen.Color := SelectedColor;
      Brush.Color := SelectedColor;
      Polygon([Point(EdgeWidth - 3, 1), Point(2, H), Point(0, H),
        Point(0, 0), Point(EdgeWidth + 1, 0)]);

      Pen.Color := clBtnShadow;
      PolyLine([Point(EdgeWidth + 1, 0), Point(EdgeWidth - 3, 0),
        Point(EdgeWidth - 3, 1), Point(1, H), Point(-1, H)]);
      //PolyLine([Point(EdgeWidth - 3, 0), Point(EdgeWidth + 1, 0),   { wrong }
      //  Point(EdgeWidth - 3, 1), Point(1, H), Point(0, H - 2)]);

      Pen.Color := clWindowFrame;
      if SoftTop then
        PolyLine([{Point(EdgeWidth, 1), }Point(EdgeWidth - 2, 1), Point(2, H),
          Point(-1, H)])
      else
        PolyLine([Point(EdgeWidth, 1), Point(EdgeWidth - 2, 1), Point(2, H),
          Point(-1, H)]);
    end;
  end;

var
  TempList: TImageList;
  SaveHeight: Integer;
begin
  MemBitmap.Canvas.Font := Font;

  { Owner }
  SaveHeight := FTabHeight;
  try
    if FStyle = tsOwnerDraw then FTabHeight := FOwnerDrawHeight
    else FTabHeight := MemBitmap.Canvas.TextHeight('T') + 4;