dfstoolbar.pas

动态提示控件

  CaptionFontRec: TLogFont;
  TM: TTextMetric;
begin
  TR := TabRect; // Save it so we don't call GetTabRect repeatedly
  // Offset so that it is client-relative instead of screen-relative
  OffsetRect(TR, -TR.Left, -TR.Top);
  if ebTop in EdgeBorders then
    OffsetRect(TR, 0, 2);
  if ebLeft in EdgeBorders then
    OffsetRect(TR, 2, 0);

  FIsHighlighted := Highlight;

  // TToolbar doesn't have a Canvas property, and it would be client area only
  // if it did.  We need the non-client area.
  TabCanvas := TCanvas.Create;
  try
    TabCanvas.Handle := GetWindowDC(Handle);

    with TabCanvas do
    begin
      if Highlight then
        Brush.Color := TabHighlightColor
      else
        Brush.Color := TabColor;
      if FMaximized then
      begin
        Pen.Color := Brush.Color;
        dec(TR.Right);
        dec(TR.Bottom);
        dec(TR.Left);
        Poly[0] := Point(TR.Right, TR.Top);
        Poly[1] := TR.BottomRight;
        Poly[2] := Point(TR.Left, TR.Bottom);
        Poly[3] := Point(TR.Left, TR.Top);
        Poly[4] := Point(TR.Right, TR.Top);
        Polygon(Poly);
        Pen.Color := clBtnShadow;
        PolyLine(Slice(Poly, 3));
        if Orientation = oHorizontal then
        begin
          // Arrow
          x := DrawArrow(TabCanvas, TR, 2, (TR.Right - TR.Left - 2) div 2,
             ArrowColor);
          inc(TR.Top, x);
        end else begin
          // Arrow
          x := DrawArrow(TabCanvas, TR, 2, (TR.Bottom - TR.Top - 2) div 2,
             ArrowColor);
          inc(TR.Left, x);
        end;
        InflateRect(TR, -2, -2);
      end else begin
        dec(TR.Right);
        dec(TR.Bottom);
        Pen.Color := cl3DDkShadow;
        Poly[0] := TR.TopLeft;
        Poly[1] := Point(TR.Right, TR.Top);
        if Orientation = oHorizontal then
          Poly[2] := Point(TR.Right - (TR.Bottom - TR.Top), TR.Bottom)
        else
          Poly[2] := Point(TR.Right, TR.Bottom - (TR.Right - TR.Left));
        Poly[3] := Point(TR.Left, TR.Bottom);
        Poly[4] := TR.TopLeft;
        Polygon(Poly);

        InflateRect(TR, -1, -1);
        if Orientation = oHorizontal then
          Dec(TR.Right)
        else
          Dec(TR.Bottom);
        Pen.Color := clWhite;
        Poly[0] := Point(TR.Left, TR.Bottom);
        Poly[1] := Point(TR.Left, TR.Top);
        Poly[2] := Point(TR.Right, TR.Top);
        Polyline(Slice(Poly, 3));
        Pen.Color := clBtnShadow;
        Poly[0] := Poly[2];
        if Orientation = oHorizontal then
          Poly[1] := Point(TR.Right - (TR.Bottom - TR.Top), TR.Bottom)
        else
          Poly[1] := Point(TR.Right, TR.Bottom - (TR.Right - TR.Left));
        Poly[2] := Point(TR.Left, TR.Bottom);
        Polyline(Slice(Poly, 3));
        if Orientation = oHorizontal then
        begin
          // Arrow
          x := DrawArrow(TabCanvas, TR, 2, (TR.Bottom - TR.Top) div 2,
             ArrowColor);
          inc(TR.Left, x + 2);
          dec(TR.Right, (TR.Bottom - TR.Top));
          InflateRect(TR, 0, -2);
        end else begin
          // Arrow
          x := DrawArrow(TabCanvas, TR, 2, (TR.Right - TR.Left) div 2,
             ArrowColor);
          inc(TR.Top, x + 2);
          dec(TR.Bottom, (TR.Right - TR.Left));
          InflateRect(TR, -2, 0);
        end;
      end;
    end;

    // Draw the texture
    // Note: This is so complex because I'm trying to make as much like the
    //       Netscape splitter as possible.  They use a 3x3 texture pattern, and
    //       that's harder to tile.  If the had used an 8x8 (or smaller
    //       divisibly, i.e. 2x2 or 4x4), I could have used Brush.Bitmap and
    //       FillRect and they whole thing would have been about half the size,
    //       twice as fast, and 1/10th as complex.
    RW := TR.Right - TR.Left;
    RH := TR.Bottom - TR.Top;
    if (RW >= TEXTURE_SIZE) and (RH >= TEXTURE_SIZE) then
    begin
      TextureBmp := TBitmap.Create;
      try
        with TextureBmp do
        begin
          Width := RW;
          Height := RH;
          // Draw first square
          Canvas.Brush.Color := TabCanvas.Brush.Color;
          Canvas.FillRect(Rect(0, 0, RW+1, RH+1));
          Canvas.Pixels[1,1] := TextureColor1;
          Canvas.Pixels[2,2] := TextureColor2;

          // Tile first square all the way across
          for x := 1 to ((RW div TEXTURE_SIZE) + ord(RW mod TEXTURE_SIZE > 0)) do
          begin
            Canvas.CopyRect(Bounds(x * TEXTURE_SIZE, 0, TEXTURE_SIZE,
               TEXTURE_SIZE), Canvas, Rect(0, 0, TEXTURE_SIZE, TEXTURE_SIZE));
          end;

          // Tile first row all the way down
          for y := 1 to ((RH div TEXTURE_SIZE) + ord(RH mod TEXTURE_SIZE > 0)) do
          begin
            Canvas.CopyRect(Bounds(0, y * TEXTURE_SIZE, RW, TEXTURE_SIZE),
               Canvas, Rect(0, 0, RW, TEXTURE_SIZE));
          end;

          // Above could be better if it reversed process when splitter was
          // taller than it was wider.  Optimized only for horizontal right now.
        end;
        // Copy texture bitmap to the screen.
        TabCanvas.CopyRect(TR, TextureBmp.Canvas, Rect(0, 0, RW, RH));
      finally
        TextureBmp.Free;
      end;
    end;

    if not Maximized then
    begin
      // Draw the caption
      TabCanvas.Font.Assign(Font);
      TabCanvas.Brush.Style := bsClear;
      GetObject(Font.Handle, SizeOf(CaptionFontRec), @CaptionFontRec);
      R := BoundsRect;
      TR := TabRect;
      if Orientation = oVertical then
      begin
        GetTextMetrics(TabCanvas.Handle, TM);
        // Has to be a true type font to be rotated.
        if (TM.tmPitchAndFamily and TMPF_TRUETYPE) = 0 then
          StrCopy(CaptionFontRec.lfFaceName, 'Arial');

        CaptionFontRec.lfOrientation := 2700;
        CaptionFontRec.lfEscapement := 2700;
        // Could do this to autofit text to the available space.  Need to change
        // the else clause below, though, to get horizontal text.
        // CaptionFontRec.lfHeight := R.Right - R.Left - 2;
        R.Top := TR.Bottom - TR.Top + 10;

        TabCanvas.Font.Handle := CreateFontIndirect(CaptionFontRec);
        TabCanvas.Brush.Style := bsClear;
        R.Left := TabCanvas.TextHeight(Caption);
        DrawText(TabCanvas.Handle, PChar(Caption), -1, R, DT_NOCLIP or
          DT_NOPREFIX or DT_SINGLELINE);
      end
      else
      begin
        OffsetRect(R, -Left, -Top);
        R.Left := TR.Right - TR.Left + 10;
        DrawText(TabCanvas.Handle, PChar(Caption), -1, R, DT_VCENTER or
          DT_NOPREFIX or DT_SINGLELINE);
      end;
    end;

  finally
    ReleaseDC(Handle, TabCanvas.Handle);
    TabCanvas.Handle := 0;
    TabCanvas.Free;
  end;
end;

procedure TdfsToolBar.SetArrowColor(const Value: TColor);
begin
  if FArrowColor <> Value then
  begin
    FArrowColor := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetTabColor(const Value: TColor);
begin
  if FTabColor <> Value then
  begin
    FTabColor := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetTabHighlightColor(const Value: TColor);
begin
  if FTabHighlightColor <> Value then
  begin
    FTabHighlightColor := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetCaption(const Value: string);
begin
  if FCaption <> Value then
  begin
    FCaption := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetHeight(const Value: integer);
begin
  if (Orientation = oHorizontal) and (not FMaximized) then
    FRestoreVal := Value
  else
    inherited Height := Value;
end;

procedure TdfsToolBar.SetMaximized(const Value: boolean);
var
  NewVal: integer;
begin
  if FMaximized <> Value then
  begin
    FMaximized := Value;
    if FMaximized then
    begin
      if Orientation = oVertical then
        inherited Width := FRestoreVal
      else
        inherited Height := FRestoreVal;
      inherited AutoSize := FRestoreAutoSize;
      DoMaximize;
    end else begin
      // AutoSize will prevent us from getting small!
      FRestoreAutoSize := AutoSize;
      inherited AutoSize := FALSE;
      if Orientation = oVertical then
      begin
        FRestoreVal := Width;
        NewVal := FTabSizeMaximized;
        if ebLeft in EdgeBorders then
          inc(NewVal, 2);
        if ebRight in EdgeBorders then
          inc(NewVal, 2);
        inherited Width := NewVal;
      end else begin
        FRestoreVal := Height;
        NewVal := FTabSizeMaximized;
        if ebTop in EdgeBorders then
          inc(NewVal, 2);
        if ebBottom in EdgeBorders then
          inc(NewVal, 2);
        inherited Height := NewVal;
      end;
      DoRestore;
    end;
    if HandleAllocated then
      InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetShowTab(const Value: boolean);
begin
  if FShowTab <> Value then
  begin
    FShowTab := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetTabIndent(const Value: integer);
begin
  if FTabIndent <> Value then
  begin
    FTabIndent := Value;
    InvalidateNonclientArea;
  end;
end;

procedure TdfsToolBar.SetTabSizeMaximized(const Value: integer);
var
  NewVal: integer;
begin
  if FTabSizeMaximized <> Value then
  begin
    FTabSizeMaximized := Value;
    if not FMaximized then
    begin
      if Orientation = oVertical then
      begin
        NewVal := FTabSizeMaximized;
        if ebLeft in EdgeBorders then
          inc(NewVal, 2);
        if ebRight in EdgeBorders then
          inc(NewVal, 2);
        inherited Width := NewVal;
      end else begin
        NewVal := FTabSizeMaximized;
        if ebTop in EdgeBorders then
          inc(NewVal, 2);
        if ebBottom in EdgeBorders then
          inc(NewVal, 2);
        inherited Height := NewVal;