如何在Delphi中更改GroupBox的边框颜色？
答案 0 :(得分：0)
来自here的示例源代码：
(*
TEXSColoredGroupBox - Eddie Shipman
TGroupBox that allows colored and flat colored bevels.
Added three properties:
*******************************************************************************
property: - BevelShadowColor-
This is the color of the Bevel's Shadow, Default clBtnShadow.
Change this color to change the color of the Bevel's Shadow.
*******************************************************************************
property: BevelHighlightColor-
This is the color of the Bevel's Highlight, Default clBtnHighlight.
Change this color to change the color of the Bevel's Highlight.
*******************************************************************************
property: BevelWidth-
This is the width of the Bevel.
*******************************************************************************
This component will also draw the frame in "flat mode" if Ctl3D is False
using the BevelShadowColor.
It still has some problems with redrawing controls in design-time but it is
usable...
*******************************************************************************
*)
unit ColoredBorderGroupBox;
interface
uses
Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
ExtCtrls, StdCtrls;
type
TEXSColoredGroupBox = class(TGroupBox)
private
{ private declarations }
FBevelLowColor: TColor;
FBevelHiColor : TColor;
FBevelWidth : Integer;
procedure SetBvlLowColor(Value: TColor);
procedure SetBvlHiColor(Value: TColor);
procedure SetBevelWidth(Value: Integer);
procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
procedure CMTextChanged(var Message: TMessage); message CM_TEXTCHANGED;
procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
procedure WMSize(var Message: TMessage); message WM_SIZE;
protected
{ protected declarations }
procedure CreateParams(Var Params:TCreateparams); override;
procedure Paint; override;
procedure SetParent(AParent:TWinControl); override;
procedure AlignControls(AControl: TControl; var Rect: TRect); override;
procedure DrawFrame(Rect:TRect);
procedure DrawFlatFrame(Rect:TRect);
procedure InvalidateFrame;
public
{ public declarations }
Constructor Create(AOwner:TComponent); override;
published
{ published declarations }
property BevelShadowColor :TColor read FBevelLowColor
write SetBvlLowColor;
property BevelHighlightColor:TColor read FBevelHiColor
write SetBvlHiColor;
property BevelWidth :Integer read FBevelWidth
write SetBevelWidth
default 1;
property Align;
property Caption;
property Color;
property Ctl3D;
property DragCursor;
property DragMode;
property Enabled;
property Font;
property ParentColor;
property ParentCtl3D;
property ParentFont;
property ParentShowHint;
property PopupMenu;
property ShowHint;
property TabOrder;
property TabStop;
property Visible;
property OnClick;
property OnDblClick;
property OnDragDrop;
property OnDragOver;
property OnendDrag;
property OnEnter;
property OnExit;
property OnMouseDown;
property OnMouseMove;
property OnMouseUp;
property OnStartDrag;
end;
procedure Register;
implementation
procedure Register;
begin
RegisterComponents('SST', [TEXSColoredGroupBox]);
end;
constructor TEXSColoredGroupBox.Create (AOwner: TComponent);
begin
inherited Create(AOwner);
ControlStyle := [csAcceptsControls, csCaptureMouse, csClickEvents,
csSetCaption, csDoubleClicks, csReplicatable];
FBevelLowColor := clBtnShadow;
FBevelHiColor := clBtnHighlight;
FBevelWidth := 1;
end;
procedure TEXSColoredGroupBox.CreateParams(Var Params:TCreateparams);
begin
inherited CreateParams (Params);
with Params.WindowClass do
Style := Style and not (CS_HREDRAW or CS_VREDRAW);
end;
procedure TEXSColoredGroupBox.Paint;
var
H: Integer;
R: TRect;
begin
// No call to inherited needed.
// inherited Paint;
with Canvas do
begin
Font := Self.Font;
H := TextHeight('0');
R := Rect(0, H div 2 - 1, Width, Height);
if Ctl3D then
begin
DrawFrame(R);
end else
begin
Brush.Color := FBevelLowColor;
DrawFlatFrame(R);
end;
if Text <> '' then
begin
R := Rect(8, 0, 0, H);
Brush.Style := bsClear;
DrawText(Handle, PChar(Text), Length(Text), R, DT_LEFT or DT_SINGLELINE
or
DT_CALCRECT);
// **********************
if not Enabled then
begin
OffsetRect(R, 1, 1);
Canvas.Font.Color := clBtnHighlight;
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
OffsetRect(R, -1, -1);
Canvas.Font.Color := clBtnShadow;
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
end
else
DrawText(Canvas.Handle, PChar(Text), Length(Text), R, DT_LEFT or
DT_SINGLELINE);
// ****************************
// DrawText(Handle, PChar(Text), Length(Text), R, );
end;
end;
end;
procedure TEXSColoredGroupBox.AlignControls(AControl: TControl; var Rect:
TRect);
begin
Canvas.Font := Font;
Inc(Rect.Top, Canvas.TextHeight('0'));
InflateRect(Rect, -1, -1);
if Ctl3d then InflateRect(Rect, -1, -1);
inherited AlignControls(AControl, Rect);
end;
procedure TEXSColoredGroupBox.SetParent(AParent:TWinControl);
begin
inherited SetParent(AParent);
if Parent <> nil then
SetWindowLong(Parent.Handle, GWL_STYLE,
GetWindowLong(Parent.Handle, GWL_STYLE)
and not WS_ClipChildren);
end;
procedure TEXSColoredGroupBox.SetBvlLowColor(Value: TColor);
begin
if FBevelLowColor <> Value then
FBevelLowColor := Value;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.SetBvlHiColor(Value: TColor);
begin
if FBevelHiColor <> Value then
FBevelHiColor := Value;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.DrawFrame(Rect: TRect);
var
CaptionLength: Integer;
begin
with Canvas do
begin
Inc(Rect.Left, FBevelWidth); // 0,5 199,5
Inc(Rect.Top, FBevelWidth); //
Dec(Rect.Right, FBevelWidth); //
Dec(Rect.Bottom, FBevelWidth); // 0,198 198,198
CaptionLength := TextWidth(Text); //
Pen.Color := FBevelHiColor; //
Pen.Width := FBevelWidth; // 1,7 200,7
MoveTo(Rect.Left, Rect.Top); //
LineTo(6,Rect.Top); //
MoveTo(8+CaptionLength+2, Rect.Top); // 1,200 200,200
LineTo(Rect.Right,Rect.Top); //
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
Pen.Color := FBevelLowColor;
Pen.Width := FBevelWidth;
OffsetRect(Rect, -FBevelWidth, -FBevelWidth);
MoveTo(Rect.Left, Rect.Top);
LineTo(6,Rect.Top);
MoveTo(8+CaptionLength+2, Rect.Top);
LineTo(Rect.Right,Rect.Top);
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
end;
end;
procedure TEXSColoredGroupBox.DrawFlatFrame(Rect: TRect);
var
CaptionLength: Integer;
begin
with Canvas do
begin
Dec(Rect.Right);
Dec(Rect.Bottom);
CaptionLength := TextWidth(Text);
Pen.Color := FBevelLowColor;
Pen.Width := FBevelWidth;
MoveTo(Rect.Left, Rect.Top);
LineTo(6,Rect.Top);
MoveTo(8+CaptionLength+2, Rect.Top);
LineTo(Rect.Right,Rect.Top);
LineTo(Rect.Right,Rect.Bottom);
LineTo(Rect.Left,Rect.Bottom);
LineTo(Rect.Left, Rect.Top);
end;
end;
procedure TEXSColoredGroupBox.CMDialogChar(var Message: TCMDialogChar);
begin
with Message do
if IsAccel(CharCode, Caption) and CanFocus then
begin
SelectFirst;
Result := 1;
end else
inherited;
end;
procedure TEXSColoredGroupBox.CMTextChanged(var Message: TMessage);
begin
inherited;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.CMCtl3DChanged(var Message: TMessage);
begin
inherited;
InvalidateFrame;
Realign;
end;
procedure TEXSColoredGroupBox.WMSize(var Message: TMessage);
begin
if (csDesigning in ComponentState) then
InvalidateFrame;
inherited;
end;
procedure TEXSColoredGroupBox.InvalidateFrame;
var
R: TRect;
begin
R := BoundsRect;
InflateRect(R, 1, 1);
If (Parent <> Nil) and Parent.HandleAllocated then
InvalidateRect(Parent.Handle, @R, True)
Else
inherited Invalidate;
end;
procedure TEXSColoredGroupBox.SetBevelWidth(Value:Integer);
begin
if Value <> FBevelWidth then
FBevelWidth := Value;
Repaint;
end;
end.