xpcheckbox.pas

非常好的xp界面控件

procedure TxpCheckBox.CMDialogChar(var Message : TCMDialogChar);
begin
  if FEnabled and (IsAccel (Message.CharCode, FCaption)) then
  begin
    if not FFocused then SetFocus;
    FOnCheckBoxClick;
  end;
end;

procedure TxpCheckBox.MouseEnter (var Message : TMessage);
begin
  if not FActive and FEnabled then
  begin
    FActive := true;
    Invalidate;
  end;
end;

procedure TxpCheckBox.MouseLeave (var Message : TMessage);
begin
  if FActive then
  begin
    FActive := False;
    Invalidate;
  end;
end;

procedure TxpCheckBox.LMouseDblClick  (var Message : TMessage);
begin
  if FEnabled then FOnCheckBoxClick;
end;

procedure TxpCheckBox.LMouseDown  (var Message : TMessage);
begin
  if not FDowned  and FEnabled then
  begin
    FDowned := true;
    if (not Focused) and (Enabled) then SetFocus;
    Invalidate;
  end;
end;

procedure TxpCheckBox.RMouseDown  (var Message : TMessage);
begin

end;

procedure TxpCheckBox.LMouseUp  (var Message : TMessage);
begin
  if FDowned and FEnabled then
  begin
    FDowned := False;
    Invalidate;
    FOnCheckBoxClick;
  end;
end;

procedure TxpCheckBox.RMouseUp  (var Message : TMessage);
begin

end;

procedure TxpCheckBox.WMSetFocus(var Message: TMessage);
begin
  if not FFocused and FEnabled then
  begin
    FFocused := true;
    Invalidate;
  end;
end;

procedure TxpCheckBox.WMKillFocus(var Message: TMessage);
begin
  if FFocused then
  begin
    FFocused := False;
    Invalidate;
  end;
end;

procedure TxpCheckBox.WMKeyDown(var Message: TMessage);
begin
  if (not FDowned) and (FEnabled) and (Message.WParam = VK_SPACE)then
  Begin
    FDowned := true;
    Invalidate;
  end;
  inherited;
end;

procedure TxpCheckBox.WMKeyUp(var Message: TMessage);
begin
  if FDowned then
  begin
    FDowned := False;
    FOnCheckBoxClick;
  end;
end;

procedure TxpCheckBox.CMEnter(var Message: TCMGotFocus);
begin
  if Assigned (FOnEnter) and FEnabled then FOnEnter (self);
end;

procedure TxpCheckBox.CMExit(var Message: TCMLostFocus);
begin
  if Assigned (FOnExit) and FEnabled then FOnExit (self);
end;



////////////////////////////////////////////////////////////////////////////////
////////////////// D R A W I N G   M E T O D S /////////////////////////////////
////////////////////////////////////////////////////////////////////////////////

procedure TxpCheckBox.DrawCheckArea  (ACanvas : TCanvas);
var
  CheckRect : TRect;
begin
  if FAlignment = cbaRight then
  begin
    CheckRect := Rect (1, HeightOf (ClientRect) div 2 - 7,
                       15, HeightOf (ClientRect) div 2 + 7);
  end
  else
  Begin
    CheckRect := Rect (Width - 15, HeightOf (ClientRect) div 2 - 7,
                       Width - 1, HeightOf (ClientRect) div 2 + 7);
  end;


  if Enabled then
  begin
    if FDowned then
    begin
      GradientFillRect (ACanvas, CheckRect, RGB (176, 176, 167), RGB (241, 239, 223),
        fdTopToBottom, 10);
    end
    else
    begin // not FDowned
      if FActive then
      begin
        GradientFillRect (ACanvas, CheckRect, RGB (255, 240, 207), RGB (248, 179, 48),
          fdTopToBottom, 10);
        ACanvas.Brush.Style := bsSolid;
        ACanvas.Pen.Style := psClear;
        ACanvas.Pen.Color := clBtnFace;
        ACanvas.Rectangle (CheckRect.Left+2, CheckRect.Top+2, CheckRect.Right-2, CheckRect.Bottom-2);
        ACanvas.Pen.Style := psSolid;
      end
      else
        GradientFillRect (ACanvas, CheckRect, RGB (220, 220, 215), RGB (255, 255, 255),
          fdTopToBottom, 10);
    end;
  end;

  ACanvas.Pen.Width := 1;
  if Enabled then
  begin
    ACanvas.Pen.Color := RGB (28, 81, 128);
    ACanvas.Brush.Style := bsClear;
  end
  else
  begin
    ACanvas.Pen.Style := psSolid;
    ACanvas.Pen.Color := clGray;
    ACanvas.Brush.Style := bsSolid;
    ACanvas.Brush.Color := clWhite;
  end;
  ACanvas.Rectangle (CheckRect.Left, CheckRect.Top, CheckRect.Right, CheckRect.Bottom);

  if FChecked then
  begin
    ACanvas.Pen.Width := 3;
    if Enabled then ACanvas.Pen.Color := FCheckColor
      else ACanvas.Pen.Color := clLtGray;
    ACanvas.MoveTo (CheckRect.Left + 3, CheckRect.Top + 6);
    ACanvas.LineTo (CheckRect.Left + 5, CheckRect.Bottom - 5);
    ACanvas.LineTo (CheckRect.Right - 5, CheckRect.Top + 4);
  end;

end;

procedure TxpCheckBox.Paint;
var
  AText : String;
  ACanvas : TBitmap;
begin
  ACanvas := TBitmap.Create;

  try
    ACanvas.Width := ClientWidth;
    ACanvas.Height := ClientHeight;

  if ParentColor then
    ACanvas.Canvas.Brush.Assign (Parent.Brush)
  else
    ACanvas.Canvas.Brush.Color := FColor;
    
  if FTransparent then
    ACanvas.Canvas.Brush.Style := bsClear
  else
    ACanvas.Canvas.Brush.Style := bsSolid;
  ACanvas.Canvas.Pen.Style := psClear;
  if not FTransparent then
    ACanvas.Canvas.FillRect (ClientRect);

  DrawCheckArea (ACanvas.Canvas);

  AText := FCaption;
  if Pos ('&', FCaption) <> 0 then Delete (AText, Pos ('&', AText), 1);


  ACanvas.Canvas.Font.Assign (FFont);
  //ACanvas.Canvas.Brush.Color := FColor;
  if FActive and FUnderLineOnActive then
    ACanvas.Canvas.Font.Style := ACanvas.Canvas.Font.Style + [fsUnderLine];

  if not Enabled then ACanvas.Canvas.Font.Color := clGray;

  ACanvas.Canvas.Brush.Style := bsClear;

  if FAlignment = cbaRight then
  begin
    //Shadow
    if FShadowText then
    begin
      ACanvas.Canvas.Font.Color := clLtGray;
      ACanvas.Canvas.TextRect (Rect (20, 2, Width-2, Height),
        21, (Height - ACanvas.Canvas.TextHeight (AText)) div 2+1, AText);
    end;
    //Text
    if  Enabled then
      ACanvas.Canvas.Font.Color := FFont.Color
    else
      ACanvas.Canvas.Font.Color := clDkGray;
    ACanvas.Canvas.TextRect (Rect (20, 2, Width-2, Height),
      20, (Height - ACanvas.Canvas.TextHeight (AText)) div 2, AText);

    if Pos ('&', FCaption) <> 0 then
    begin
      ACanvas.Canvas.Pen.Color := ACanvas.Canvas.Font.Color;
      ACanvas.Canvas.Pen.Width := 1;
      ACanvas.Canvas.MoveTo (20 + ACanvas.Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption)-1)),
                     2 + ACanvas.Canvas.TextHeight (AText));
      ACanvas.Canvas.LineTo (20 + ACanvas.Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption))),
                     2 + ACanvas.Canvas.TextHeight (AText));
    end;
  end
  else
  begin
    //Shadow
    ACanvas.Canvas.Font.Color := clLtGray;
    ACanvas.Canvas.TextRect (Rect (2, 2, Width-20, Height),
      3, (Height - ACanvas.Canvas.TextHeight (AText)) div 2+1, AText);
    //Text
    if  Enabled then
      ACanvas.Canvas.Font.Color := FFont.Color
    else
      ACanvas.Canvas.Font.Color := clDkGray;
    ACanvas.Canvas.TextRect (Rect (2, 2, Width-20, Height),
      2, (Height - ACanvas.Canvas.TextHeight (AText)) div 2, AText);
    if Pos ('&', FCaption) <> 0 then
    begin
      ACanvas.Canvas.Pen.Color := ACanvas.Canvas.Font.Color;
      ACanvas.Canvas.Pen.Width := 1;
      ACanvas.Canvas.MoveTo (ACanvas.Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption)-1)),
                     2 + ACanvas.Canvas.TextHeight (AText));
      ACanvas.Canvas.LineTo (ACanvas.Canvas.TextWidth (Copy (AText, 1, Pos ('&', FCaption))),
                     2 + ACanvas.Canvas.TextHeight (AText));
    end;
  end;

  if Enabled and FFocused then
  begin
    ACanvas.Canvas.Brush.Style := bsSolid;
    if FAlignment = cbaRight then
      ACanvas.Canvas.DrawFocusRect (Rect (17, 1, ACanvas.Canvas.TextWidth (AText) + 25, Height - 1))
    else
      ACanvas.Canvas.DrawFocusRect (Rect (1, 1, ACanvas.Canvas.TextWidth (AText) + 8, Height - 1));
  end;
    BitBlt(Canvas.Handle, 0, 0, ACanvas.Width, ACanvas.Height,
      ACanvas.Canvas.Handle, 0, 0, SRCCOPY); //SRCCOPY
  finally
    ACanvas.Free;
  end;
  
end;


procedure Register;
begin
  RegisterComponents('XP Controls', [TxpCheckBox]);
end;

end.