dfsclrbn.pas

动态提示控件

end;

procedure TdfsColorButton.SetColor(Value: TColor);
var
  x: integer;
  Found: boolean;
begin
  if Value <> FColor then
  begin
    FColor := Value;
    Found := FALSE;
    for x := 1 to FPaletteColors.Count do
    begin
      if FColor = FPaletteColors.Colors[x] then
      begin
        FCurrentPaletteIndex := x;
        Found := TRUE;
        break;
      end;
    end;
    if not Found then
      FCurrentPaletteIndex := 0;

    Invalidate;
    DoColorChange;
  end;
end;

procedure TdfsColorButton.SetPaletteColorIndex(Value: integer);
begin
  if (Value <> FCurrentPaletteIndex) and (Value >= 0) and
     (Value <= FPaletteColors.Count) then
  begin
    FCurrentPaletteIndex := Value;
    if Value = 0 then
      FColor := OtherColor
    else
      FColor := FPaletteColors.Colors[Value];
    Invalidate;
    DoColorChange;
  end;
end;

procedure TdfsColorButton.CNMeasureItem(var Msg: TWMMeasureItem);
begin
  with Msg.MeasureItemStruct^ do
  begin
    itemWidth := Width;
    itemHeight := Height;
  end;
  Msg.Result := 1;
end;

procedure TdfsColorButton.CNDrawItem(var Msg: TWMDrawItem);
begin
  DrawItem(Msg.DrawItemStruct^);
  Msg.Result := 1;
end;

{ Borrowed from RxLib }
procedure ShadeRect(DC: HDC; const Rect: TRect);
const
  HatchBits: array[0..7] of Word = ($11, $22, $44, $88, $11, $22, $44, $88);
var
  Bitmap: HBitmap;
  SaveBrush: HBrush;
  SaveTextColor, SaveBkColor: TColorRef;
begin
  Bitmap := CreateBitmap(8, 8, 1, 1, @HatchBits);
  SaveBrush := SelectObject(DC, CreatePatternBrush(Bitmap));
  try
    SaveTextColor := SetTextColor(DC, clWhite);
    SaveBkColor := SetBkColor(DC, clBlack);
    with Rect do PatBlt(DC, Left, Top, Right - Left, Bottom - Top, $00A000C9);
    SetBkColor(DC, SaveBkColor);
    SetTextColor(DC, SaveTextColor);
  finally
    DeleteObject(SelectObject(DC, SaveBrush));
    DeleteObject(Bitmap);
  end;
end;


(* There's a bug in the Delphi 2.0x optimization compiler.  If you don't turn
   off optimization under Delphi 2.0x, you will get an internal error C1217.
   This bug is not present in Delphi 1 or 3.
   There appears to be a similar bug in C++Builder 1.  I get an internal error
   C1310.  Same fix for it as for Delphi.  Doesn't appear in C++Builder 3.    *)

{$IFDEF DFS_COMPILER_2}
  {$IFOPT O+}
    {$DEFINE DFS_OPTIMIZATION_ON}
    {$O-}
  {$ENDIF}
{$ENDIF}
procedure TdfsColorButton.DrawItem(const DrawItemStruct: TDrawItemStruct);
var
  IsDown, IsDefault: Boolean;
  R: TRect;
  Flags: Longint;
  CursorPos: TPoint;
  BtnRect: TRect;
  Bmp: TBitmap;
{$IFNDEF DFS_WIN32}
  NewStyle: boolean;
  Bevel: integer;
  TextBounds: TRect;
{$ENDIF}
begin
  FCanvas.Handle := DrawItemStruct.hDC;
  try
    R := ClientRect;

    with DrawItemStruct do
    begin
      IsDown := (itemState and ODS_SELECTED <> 0) or (FPaletteDisplayed);
      IsDefault := itemState and ODS_FOCUS <> 0;
    end;

    GetCursorPos(CursorPos);
    BtnRect.TopLeft := Parent.ClientToScreen(Point(Left, Top));
    BtnRect.BottomRight := Parent.ClientToScreen(Point(Left + Width,
       Top + Height));
    FIsMouseOver := PtInRect(BtnRect, CursorPos);

{$IFDEF DFS_WIN32}
    Flags := DFCS_BUTTONPUSH or DFCS_ADJUSTRECT;
    if IsDown then Flags := Flags or DFCS_PUSHED;
    if DrawItemStruct.itemState and ODS_DISABLED <> 0 then
      Flags := Flags or DFCS_INACTIVE;
    { Don't draw flat if mouse is over it or has the input focus }
    if FFlat and (not FIsMouseOver) and (not Focused) then
      Flags := Flags or DFCS_FLAT;

    if IsDown then
    begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Style := bsClear;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);

      { DrawFrameControl must draw within this border }
      InflateRect(R, -1, -1);
    end;

    { DrawFrameControl does not draw a pressed button correctly }
    if IsDown then
    begin
      FCanvas.Pen.Color := clBtnShadow;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Color := clBtnFace;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
      InflateRect(R, -1, -1);
    end else begin
      if (csDesigning in ComponentState) or
         (FFlat and ((Flags and DFCS_FLAT) = 0)) then
      begin
        // Flat, but it has focus or mouse is over.
        FCanvas.Pen.Color := clBtnHighlight;
        FCanvas.MoveTo(R.Left, R.Bottom-1);
        FCanvas.LineTo(R.Left, R.Top);
        FCanvas.LineTo(R.Right-1, R.Top);
        FCanvas.Pen.Color := clBtnShadow;
        FCanvas.LineTo(R.Right-1, R.Bottom-1);
        FCanvas.LineTo(R.Left, R.Bottom-1);
        InflateRect(R, -1, -1);
        FCanvas.Brush.Color := clBtnFace;
        FCanvas.FillRect(R);
      end else begin
        DrawFrameControl(DrawItemStruct.hDC, R, DFC_BUTTON, Flags);
        if (Flags and DFCS_FLAT) <> 0 then
        begin
          { I don't know why, but it insists on drawing this little rectangle }
          InflateRect(R, 2, 2);
          FCanvas.Brush.Color := clBtnFace;
          FCanvas.FrameRect(R);
          InflateRect(R, -2, -2);
        end;
      end;
    end;

    R := ClientRect;
    if IsDown then
      OffsetRect(R, 1, 1);
    InflateRect(R, -3, -3);
    if IsFocused and IsDefault then
    begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Brush.Color := clBtnFace;
      DrawFocusRect(FCanvas.Handle, R);
    end;
    InflateRect(R, -1, -1);
{$ELSE}

    NewStyle := ((Style = bsAutoDetect) and NewStyleControls) or (Style = bsNew);

    if NewStyle then Bevel := 1
    else Bevel := 2;

    R := DrawButtonFace(FCanvas, ClientRect, Bevel, FStyle, not NewStyle,
      IsDown, IsDefault or IsFocused);

    if IsDefault then
    begin
      FCanvas.Brush.Color := clBtnFace;
      TextBounds := R;
      if NewStyle then
      begin
        InflateRect(TextBounds, -2, -2);
        if IsDown then OffsetRect(TextBounds, -1, -1);
      end
      else InflateRect(TextBounds, -2, -2);
      DrawFocusRect(FCanvas.Handle, TextBounds);
    end;
    InflateRect(R, -3, -3);

{$ENDIF}

    { Draw the color rect }
    InflateRect(R, -2, -1);
    Dec(R.Right, 10);
    if (not Enabled) or ((DrawItemStruct.itemState and ODS_DISABLED) <> 0) then
    begin
      FCanvas.Brush.Color := clWindowFrame;
      FCanvas.FrameRect(R);
      InflateRect(R, -1, -1);
      ShadeRect(FCanvas.Handle, R);
    end else begin
      FCanvas.Pen.Color := clWindowFrame;
      FCanvas.Pen.Width := 1;
      FCanvas.Brush.Style := bsClear;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
      FCanvas.Brush.Color := FColor;
      FCanvas.Rectangle(R.Left, R.Top, R.Right, R.Bottom);
    end;

    { Draw divider line }
    R.Left := R.Right + 3;
    FCanvas.Pen.Color := clBtnShadow;
    FCanvas.MoveTo(R.Left, R.Top);
    FCanvas.LineTo(R.Left, R.Bottom);
    inc(R.Left);
    FCanvas.Pen.Color := clBtnHighlight;
    FCanvas.MoveTo(R.Left, R.Top);
    FCanvas.LineTo(R.Left, R.Bottom);

    { Draw the arrow }
    if Enabled or ((DrawItemStruct.itemState and ODS_DISABLED) = 0) then
      Bmp := FArrowBmp
    else
      Bmp := FDisabledArrowBmp;
    inc(R.Left, 1);
    inc(R.Top, ((R.Bottom - R.Top) div 2) - (Bmp.Height div 2));
    R.Right := R.Left + Bmp.Width-1;
    R.Bottom := R.Top + Bmp.Height-1;
    FCanvas.Brush.Color := clBtnFace;
    FCanvas.BrushCopy(R, Bmp, Rect(0, 0, Bmp.Width-1, Bmp.Height-1),
       Bmp.Canvas.Pixels[0, Bmp.Height-1]);
  finally
    FCanvas.Handle := 0;
  end;
end;
{$IFDEF DFS_OPTIMIZATION_ON}
  {$O+}
  {$UNDEF DFS_OPTIMIZATION_ON}
{$ENDIF}


procedure TdfsColorButton.CMFontChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TdfsColorButton.CMEnabledChanged(var Message: TMessage);
begin
  inherited;
  Invalidate;
end;

procedure TdfsColorButton.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
  Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;

procedure TdfsColorButton.SetButtonStyle(ADefault: Boolean);
begin
  if ADefault <> IsFocused then
  begin
    IsFocused := ADefault;
    Refresh;
  end;
end;

procedure TdfsColorButton.Click;
var
  PalXY: TPoint;
  ArrowHit: boolean;
  NewIdx: integer;
  CursorPos: TPoint;
  ParentForm: TCustomForm;
{$IFDEF DFS_WIN32}
  ScreenRect: TRect;
{$ENDIF}
begin
  if FInhibitClick then
  begin
    FInhibitClick := FALSE;
    exit;
  end;

  if not FIgnoreTopmosts then
{$IFDEF DFS_DELPHI_3_UP}
    Application.NormalizeAllTopMosts;
{$ELSE}
    Application.NormalizeTopMosts;
{$ENDIF}

  GetCursorPos(CursorPos);
  CursorPos := ScreenToClient(CursorPos);
  ArrowHit := CursorPos.X > (Width - 13);
  if FCycleColors and (not ArrowHit) then
  begin
    NewIdx := FCurrentPaletteIndex + 1;
    if NewIdx > PaletteColors.Count then
      PaletteColorIndex := 0
    else
      PaletteColorIndex := NewIdx;
  end else begin
    FPaletteForm := TdfsColorButtonPalette.Create(Self);
    PalXY := Parent.ClientToScreen(Point(Left, Top + Height));
  {$IFDEF DFS_WIN32}
    { Screen.Width and Height don't account for non-hidden task bar. }
    SystemParametersInfo(SPI_GETWORKAREA, 0, @ScreenRect, 0);
    if PalXY.Y + FPaletteForm.Height > ScreenRect.Bottom then
      { No room to display below the button, show it above instead }
      PalXY := Parent.ClientToScreen(Point(Left, Top - 121));
    if PalXY.X < ScreenRect.Left then
      { No room to display horizontally, shift right }
      PalXY.X := ScreenRect.Left