dfssplitter.pas

动态提示控件

    begin
      Result := ClientRect;
      if Align in [alLeft, alRight] then
      begin
        Result.Top := (ClientRect.Bottom - ClientRect.Top - BW) div 2;
        Result.Bottom := Result.Top + BW;
        InflateRect(Result, -1, 0);
      end
      else
      begin
        Result.Left := (ClientRect.Right - ClientRect.Left - BW) div 2;
        Result.Right := Result.Left + BW;
        InflateRect(Result, 0, -1);
      end;
    end;
  end;
  if not IsRectEmpty(Result) then
  begin
    if Result.Top < 1 then
      Result.Top := 1;
    if Result.Left < 1 then
      Result.Left := 1;
    if Result.Bottom >= ClientRect.Bottom then
      Result.Bottom := ClientRect.Bottom - 1;
    if Result.Right >= ClientRect.Right then
      Result.Right := ClientRect.Right - 1;
    // Make smaller if it's beveled
    if Beveled then
      if Align in [alLeft, alRight] then
        InflateRect(Result, -3, 0)
      else
        InflateRect(Result, 0, -3);
  end;
  FLastKnownButtonRect := Result;
end;

procedure TdfsSplitter.Paint;
begin
// Exclude button rect from update region here for less flicker.
  inherited Paint;

// Don't paint while being moved unless ResizeStyle = rsUpdate!!!
// Make rect smaller if Beveled is true.
  PaintButton(FIsHighlighted);
end;

{$IFDEF DFS_COMPILER_4_UP}
function TdfsSplitter.DoCanResize(var NewSize: integer): boolean;
begin
  Result := inherited DoCanResize(NewSize);
  // D4 version has a bug that causes it to not honor MinSize, which causes a
  // really nasty problem.
  if Result and (NewSize < MinSize) then
    NewSize := MinSize;
end;
{$ENDIF}

procedure TdfsSplitter.PaintButton(Highlight: boolean);
const
  TEXTURE_SIZE = 3;
var
  BtnRect: TRect;
  CaptionBtnRect: TRect;
  BW: integer;
  TextureBmp: TBitmap;
  x, y: integer;
  RW, RH: integer;
  OffscreenBmp: TBitmap;
  WinButton: array[0..2] of TdfsWindowsButton;
  b: TdfsWindowsButton;
  BtnFlag: UINT;
begin
  if (not FShowButton) or (not Enabled) or (GetParentForm(Self) = NIL) then
    exit;

  if FAutoHighLightColor then
    FButtonHighlightColor := GrabBarColor;

  BtnRect := ButtonRect; // So we don't repeatedly call GetButtonRect
  if IsRectEmpty(BtnRect) then
    exit; // nothing to draw

  OffscreenBmp := TBitmap.Create;
  try
    OffsetRect(BtnRect, -BtnRect.Left, -BtnRect.Top);
    OffscreenBmp.Width := BtnRect.Right;
    OffscreenBmp.Height := BtnRect.Bottom;

    if ButtonStyle = bsWindows then
    begin
      OffscreenBmp.Canvas.Brush.Color := Color;
      OffscreenBmp.Canvas.FillRect(BtnRect);
      if Align in [alLeft, alRight] then
        BW := BtnRect.Right
      else
        BW := BtnRect.Bottom;
      FillChar(WinButton, SizeOf(WinButton), 0);
      x := 0;
      if Align in [alLeft, alRight] then
      begin
        for b := High(TdfsWindowsButton) downto Low(TdfsWindowsButton) do
          if b in WindowsButtons then
          begin
            WinButton[x] := b;
            inc(x);
          end;
      end
      else
      begin
        for b := Low(TdfsWindowsButton) to High(TdfsWindowsButton) do
          if b in WindowsButtons then
          begin
            WinButton[x] := b;
            inc(x);
          end;
      end;
      for x := 0 to VisibleWinButtons - 1 do
      begin
        if Align in [alLeft, alRight] then
          CaptionBtnRect := Bounds(0, x * BW, BW, BW)
        else
          CaptionBtnRect := Bounds(x * BW, 0, BW, BW);
        BtnFlag := 0;
        case WinButton[x] of
          wbMin:
            begin
              if Minimized then
                BtnFlag := DFCS_CAPTIONRESTORE
              else
                BtnFlag := DFCS_CAPTIONMIN;
            end;
          wbMax:
            begin
              if Maximized then
                BtnFlag := DFCS_CAPTIONRESTORE
              else
                BtnFlag := DFCS_CAPTIONMAX;
            end;
          wbClose:
            begin
              BtnFlag := DFCS_CAPTIONCLOSE;
            end;
        end;
        DrawFrameControl(OffscreenBmp.Canvas.Handle, CaptionBtnRect, DFC_CAPTION,
          BtnFlag);
      end;
    end
    else
    begin
      // Draw basic button
      OffscreenBmp.Canvas.Brush.Color := clGray;
      OffscreenBmp.Canvas.FrameRect(BtnRect);
      InflateRect(BtnRect, -1, -1);

      OffscreenBmp.Canvas.Pen.Color := clWhite;
      with BtnRect, OffscreenBmp.Canvas do
      begin
        // This is not going to work with the STB bug.  Have to find workaround.
        MoveTo(Left, Bottom-1);
        LineTo(Left, Top);
        LineTo(Right, Top);
      end;
      Inc(BtnRect.Left);
      Inc(BtnRect.Top);

      if Highlight then
        OffscreenBmp.Canvas.Brush.Color := ButtonHighlightColor
      else
        OffscreenBmp.Canvas.Brush.Color := ButtonColor;
      OffscreenBmp.Canvas.FillRect(BtnRect);
      FIsHighlighted := Highlight;
      Dec(BtnRect.Right);
      Dec(BtnRect.Bottom);

      // Draw the insides of the button
      with BtnRect do
      begin
        // Draw the arrows
        if Align in [alLeft, alRight] then
        begin
          InflateRect(BtnRect, 0, -4);
          BW := BtnRect.Right - BtnRect.Left;
          DrawArrow(OffscreenBmp.Canvas, BtnRect, 1, BW, ArrowColor);
          BW := DrawArrow(OffscreenBmp.Canvas, BtnRect, -1, BW, ArrowColor);
          InflateRect(BtnRect, 0, -(BW+4));
        end else begin
          InflateRect(BtnRect, -4, 0);
          BW := BtnRect.Bottom - BtnRect.Top;
          DrawArrow(OffscreenBmp.Canvas, BtnRect, 1, BW, ArrowColor);
          BW := DrawArrow(OffscreenBmp.Canvas, BtnRect, -1, BW, ArrowColor);
          InflateRect(BtnRect, -(BW+4), 0);
        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 := BtnRect.Right - BtnRect.Left;
        RH := BtnRect.Bottom - BtnRect.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 := OffscreenBmp.Canvas.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.
            OffscreenBmp.Canvas.CopyRect(BtnRect, TextureBmp.Canvas,
               Rect(0, 0, RW, RH));
          finally
            TextureBmp.Free;
          end;
        end;
      end;
    end;
(**)
    Canvas.CopyRect(ButtonRect, OffscreenBmp.Canvas, Rect(0, 0,
       OffscreenBmp.Width, OffscreenBmp.Height));
  finally
    OffscreenBmp.Free;
  end;
end;

procedure TdfsSplitter.SetButtonWidth(const Value: integer);
begin
  if Value <> FButtonWidth then
  begin
    FButtonWidth := Value;
    if (FButtonWidthType = btwPercentage) and (FButtonWidth > 100) then
      FButtonWidth := 100;
    if FButtonWidth < 0 then
      FButtonWidth := 0;
    if (ButtonStyle = bsNetscape) and ShowButton then
      Invalidate;
  end;
end;

procedure TdfsSplitter.SetButtonWidthType(const Value: TdfsButtonWidthType);
begin
  if Value <> FButtonWidthType then
  begin
    FButtonWidthType := Value;
    if (FButtonWidthType = btwPercentage) and (FButtonWidth > 100) then
      FButtonWidth := 100;
    if (ButtonStyle = bsNetscape) and ShowButton then
      Invalidate;
  end;
end;

procedure TdfsSplitter.SetShowButton(const Value: boolean);
begin
  if Value <> FShowButton then
  begin
    FShowButton := Value;
    SetRectEmpty(FLastKnownButtonRect);
    Invalidate;
  end;
end;

procedure TdfsSplitter.WMMouseMove(var Msg: TWMMouseMove);
begin
  if AllowDrag then
  begin
    inherited;

    // The order is important here.  ButtonHitTest must be evaluated before
    // the ButtonStyle because it will change the cursor (over button or not).
    // If the order were reversed, the cursor would not get set for bsWindows
    // style since short-circuit boolean eval would stop it from ever being
    // called in the first place.
    if ButtonHitTest(Msg.XPos, Msg.YPos) and (ButtonStyle = bsNetscape) then
    begin
      if not FIsHighlighted then
        PaintButton(TRUE)
    end else
      if FIsHighlighted then
        PaintButton(FALSE);
  end else
    DefaultHandler(Msg); // Bypass TSplitter and just let normal handling occur.
end;

procedure TdfsSplitter.CMMouseEnter(var Msg: TWMMouse);
var
  Pos: TPoint;
begin
  inherited;

  GetCursorPos(Pos); // CM_MOUSEENTER doesn't send mouse pos.
  Pos := Self.ScreenToClient(Pos);
  // The order is important here.  ButtonHitTest must be evaluated before
  // the ButtonStyle because it will change the cursor (over button or not).
  // If the order were reversed, the cursor would not get set for bsWindows
  // style since short-circuit boolean eval would stop it from ever being
  // called in the first place.
  if ButtonHitTest(Pos.x, Pos.y) and (ButtonStyle = bsNetscape) then
  begin
    if not FIsHighlighted then
      PaintButton(TRUE)
  end else
    if FIsHighlighted then
      PaintButton(FALSE);
end;

procedure TdfsSplitter.CMMouseLeave(var Msg: TWMMouse);
begin
  inherited;

  if (ButtonStyle = bsNetscape) and FIsHighlighted then
    PaintButton(FALSE);

  FGotMouseDown := FALSE;
end;

procedure TdfsSplitter.WMLButtonDown(var Msg: TWMLButtonDown);
begin
  if Enabled then
  begin
    FGotMouseDown := ButtonHitTest(Msg.XPos, Msg.YPos);
    if FGotMouseDown then
    begin
      FindControl;
      FDownPos := ClientToScreen(Point(Msg.XPos, Msg.YPos));
    end;
  end;
  if AllowDrag then
    inherited // Let TSplitter have it.
  else
    // Bypass TSplitter and just let normal handling occur. Prevents drag painting.
    DefaultHandler(Msg);
end;

procedure TdfsSplitter.WMLButtonUp(var Msg: TWMLButtonUp);
var
  CurPos: TPoint;
  OldMax: boolean;
begin
  inherited;

  if FGotMouseDown then
  begin
    if ButtonHitTest(Msg.XPos, Msg.YPos) then
    begin
      CurPos := ClientToScreen(Point(Msg.XPos, Msg.YPos));
      // More than a little movement is not a click, but a regular resize.
      if ((Align in [alLeft, alRight]) and
         (Abs(FDownPos.x - CurPos.X) <= MOVEMENT_TOLERANCE)) or
         ((Align in [alTop, alBottom]) and
         (Abs(FDownPos.y - CurPos.Y) <= MOVEMENT_TOLERANCE)) then
      begin
        StopSizing;
        if ButtonStyle = bsNetscape then
          Maximized := not Maximized
        else
          case WindowButtonHitTest(Msg.XPos, Msg.YPos) of
            wbMin: Minimized := not Minimized;
            wbMax: Maximized := not Maximized;
            wbClose: DoClose;
          end;
      end;
    end;
    FGotMouseDown := FALSE;
  end
  else if AllowDrag then
  begin
    FindControl;
    if FControl = NIL then
      exit;

    OldMax := FMaximized;
    case Align of
      alLeft, alRight: FMaximized := FControl.Width <= MinSize;
      alTop, alBottom: FMaximized := FControl.Height <= MinSize;
    end;
    if FMaximized then
    begin
      UpdateControlSize(MinSize);
      if not OldMax then
        DoMaximize;
    end
    else
    begin
      case Align of
        alLeft,
        alRight:  FRestorePos := FControl.Width;
        alTop,
        alBottom: FRestorePos := FControl.Height;
      end;
      if OldMax then
        DoRestore;
    end;
  end;
  Invalidate;
end;

function TdfsSplitter.WindowButtonHitTest(X, Y: integer): TdfsWindowsButton;
var
  BtnRect: TRect;
  i: integer;
  b: TdfsWindowsButton;
  WinButton: array[0..2] of TdfsWindowsButton;
  BW: integer;
  BRs: array[0..2] of TRect;
begin
  Result := wbMin;
  // Figure out which one was hit.  This function assumes ButtonHitTest has
  // been called and returned TRUE.
  BtnRect := ButtonRect; // So we don't repeatedly call GetButtonRect
  i := 0;
  if Align in [alLeft, alRight] then
  begin
    for b := High(TdfsWindowsButton) downto Low(TdfsWindowsButton) do
      if b in WindowsButtons then
      begin
        WinButton[i] := b;
        inc(i);
      end;
  end
  else
    for b := Low(TdfsWindowsButton) to High(TdfsWindowsButton) do
      if b in WindowsButtons then
      begin
        WinButton[i] := b;
        inc(i);
      end;

  if Align in [alLeft, alRight] then
    BW := BtnRect.Right - BtnRect.Left
  else
    BW := BtnRect.Bottom - BtnRect.Top;
  FillChar(BRs, SizeOf(BRs), 0);
  for i := 0 to VisibleWinButtons - 1 do
    if ((Align in [alLeft, alRight]) and PtInRect(Bounds(BtnRect.Left,
      BtnRect.Top + (BW * i), BW, BW), Point(X, Y))) or ((Align in [alTop,
      alBottom]) and PtInRect(Bounds(BtnRect.Left + (BW * i), BtnRect.Top, BW,