dfstoolbar.pas

动态提示控件

      end;
    end;
    InvalidateNonclientArea;
  end;
end;

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

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

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

procedure TdfsToolBar.SetVersion(const Value: string);
begin
  { empty write method, just needed to get it to show up in Object Inspector }
end;

procedure TdfsToolBar.SetWidth(const Value: integer);
begin
  if (Orientation = oVertical) and (not FMaximized) then
    FRestoreVal := Value
  else
    inherited Width := Value;
end;

procedure TdfsToolBar.WMNCCalcSize(var Message: TWMNCCalcSize);
begin
  inherited;

  if FShowTab then
  begin
    if FMaximized then
    begin
      // Take away some client area (make it non-client) to make room for tab.
      with Message.CalcSize_Params^ do
        if Orientation = oVertical then
          inc(rgrc[0].Top, FTabSizeMaximized + FTabIndent)
        else
          inc(rgrc[0].Left, FTabSizeMaximized + FTabIndent);
    end else begin
      // Everything is non-client, there is no client area, i.e. where toolbar
      // buttons go.  I originally made the rect empty, but that didn't work
      // with toolbars that had AutoSize set to false, so now I move the client
      // rect completely out of the window available.
      with Message.CalcSize_Params^ do
//        SetRectEmpty(rgrc[0]);
      begin
        if Orientation = oVertical then
          inc(rgrc[0].Top, Height)
        else
          inc(rgrc[0].Left, Width);
      end;
    end;
    Message.Result := 0;
  end;
end;

procedure TdfsToolBar.WMNCPaint(var Message: TWMNCPaint);
var
  Pt: TPoint;
begin
  inherited;

  if FShowTab then
  begin
    GetCursorPos(Pt);
    PaintTab(TabHitTest(Pt.x, Pt.y));
  end;
end;

// X, Y are screen-relative, not client-relative!!!
function TdfsToolBar.TabHitTest(X, Y: integer): boolean;
begin
  Result := PtInRect(TabRect{FLastKnownTabRect}, Point(X, Y));
end;

procedure TdfsToolBar.WMNCLButtonDown(var Message: TWMNCLButtonDown);
begin
  FGotMouseDown := (Message.HitTest = HTCAPTION);
  if FGotMouseDown then
    Message.Result := 0
  else
    inherited;
end;

procedure TdfsToolBar.WMNCLButtonUp(var Message: TWMNCLButtonUp);
begin
  inherited;

  if FGotMouseDown and (Message.HitTest = HTCAPTION) and
     not (csDesigning in ComponentState) then
  begin
    Maximized := not Maximized;

    FGotMouseDown := FALSE;
  end;
end;

procedure TdfsToolBar.WMNCHitTest(var Message: TWMNCHitTest);
begin
  inherited;

  if TabHitTest(Message.XPos, Message.YPos) then
  begin
    if csDesigning in ComponentState then
      Message.Result := HTCLIENT // Click to select in IDE.
    else
      Message.Result := HTCAPTION; // Generate WMNCLButtonXXX messages.

    if not FIsHighlighted then
      PaintTab(TRUE);
  end else
    if FIsHighlighted then
      PaintTab(FALSE);
end;

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

  if FIsHighlighted then
    PaintTab(FALSE);
end;

function TdfsToolBar.DrawArrow(ACanvas: TCanvas; AvailableRect: TRect;
  Offset, ArrowSize: integer; Color: TColor): integer;
var
  x, y, q, i, j: integer;
  ArrowAlign: TAlign;
  OldPen: TColor;
begin
  if not Odd(ArrowSize) then
    Dec(ArrowSize);
  if ArrowSize < 1 then
    ArrowSize := 1;

  // The ArrowAlign value is pretty much meaningless as far as a direction goes.
  // I'm just making up a value so I can tell what way I want it done.
  if FMaximized then
  begin
    if Orientation = oVertical then
      ArrowAlign := alRight
    else
      ArrowAlign := alLeft;
  end else begin
    if Orientation = oVertical then
      ArrowAlign := alTop
    else
      ArrowAlign := alBottom;
  end;
  q := ArrowSize * 2 - 1 ;
  Result := q;
  OldPen := ACanvas.Pen.Color;
  ACanvas.Pen.Color := Color;
  with AvailableRect do
  begin
    case ArrowAlign of
      alBottom:
        begin
          if Offset < 0 then
            x := Right + Offset - q
          else
            x := Left + Offset;
          y := Top + ((Bottom - Top - q + 1) div 2);
          for j := x to x + ArrowSize - 1 do
          begin
            for i := y to y + q - 1 do
              ACanvas.Pixels[j, i] := Color;
            inc(y);
            dec(q,2);
          end;
        end;
      alTop:
        begin
          x := Left + ((Right - Left - q + 1) div 2);
          if Offset < 0 then
            y := Bottom + Offset - q
          else
            y := Top + Offset;
          for i := y to y + ArrowSize - 1 do
          begin
            for j := x to x + q - 1 do
              ACanvas.Pixels[j, i] := Color;
            inc(x);
            dec(q,2);
          end;
        end;
      alRight:
        begin
          y := Top + ((Bottom - Top - q) div 2);
          if Offset < 0 then
            x := Left + Offset - q
          else
            x := Left + Offset;
          for j := x to x + ArrowSize - 1 do
          begin
            for i := y to y + q - 1 do
              ACanvas.Pixels[j, i] := Color;
            inc(y);
            dec(q,2);
          end;
        end;
    else // alLeft
      x := Left + ((Right - Left - q) div 2) + 1;
      if Offset < 0 then
        y := Bottom + Offset - q
      else
        y := Top + Offset;
      for i := y to y + ArrowSize - 1 do
      begin
        for j := x to x + q - 1 do
          ACanvas.Pixels[j, i] := Color;
        inc(x);
        dec(q,2);
      end;
    end;
  end;
  ACanvas.Pen.Color := OldPen;
end;

procedure TdfsToolBar.DoMaximize;
begin
  if assigned(FOnMaximize) then
    FOnMaximize(Self);
end;

procedure TdfsToolBar.DoRestore;
begin
  if assigned(FOnRestore) then
    FOnRestore(Self);
end;

function TdfsToolBar.GetAutoSize: boolean;
begin
  // If the component is being written to the DFM file, we need to tell it the
  // toolbar's real AutoSize state if it's minimized.
  if (csWriting in ComponentState) and (not Maximized) then
    Result := FRestoreAutoSize
  else
    Result := inherited AutoSize;
end;

procedure TdfsToolBar.ReplacementSetAutoSize(Value: boolean);
begin
  FRestoreAutoSize := Value;
  // Don't pass it on if we are minimized!
  if FMaximized then
    inherited AutoSize := Value;
end;


function TdfsToolBar.GetAlign: TAlign;
begin
  Result := inherited Align;
end;

procedure TdfsToolBar.SetAlign(const Value: TAlign);
begin
  inherited Align := Value;
  InvalidateNonclientArea;
end;

procedure TdfsToolBar.CMFontChanged(var TMessage);
begin
  inherited;
  InvalidateNonclientArea;
end;

procedure TdfsToolBar.InvalidateNonclientArea;
begin
  // Cause non-client area to repaint
  SetWindowPos(Handle, 0, 0, 0, 0, 0, SWP_FRAMECHANGED or SWP_NOACTIVATE or
     SWP_NOMOVE or SWP_NOSIZE or SWP_NOZORDER);
end;

function TdfsToolBar.GetOrientation: TdfsOrientation;
var
  R: TRect;
begin
  if Align in [alTop, alBottom] then
    Result := oHorizontal
  else if Align in [alLeft, alRight] then
    Result := oVertical
  else
  begin
    R := BoundsRect;
    if (R.Right - R.Left) > (R.Bottom - R.Top) then
      Result := oHorizontal
    else
      Result := oVertical;
  end;
end;

procedure TdfsToolBar.Resize;
begin
  InvalidateNonclientArea;
  inherited;
end;

end.