右側が、マウスカーソルが、ＣｈｅｃｋＢｏｘの領域内にはいった場合で、MyRadioButton と同じ様に、明るさを変えています。
色によっては、明るい色が正しく表現できない場合があります、その時は、色をの変化を作り出す係数を変更して下さい。
MyCheckBox
MyCheckBoxは、MyRadioButtonと同じで、フォントと、フォントの領域に色をつけられる様にしたものです。
ＴＣａｎｖａｓを追加して、文字と、文字領域を描画し指定された色をつけています。
右側が、マウスカーソルが、ＣｈｅｃｋＢｏｘの領域内にはいった場合で、MyRadioButton と同じ様に、明るさを変えています。
色によっては、明るい色が正しく表現できない場合があります、その時は、色をの変化を作り出す係数を変更して下さい。
unit MyCheckBox;
interface
uses
Windows, Messages, Classes, Graphics, Controls, Forms, Dialogs,
StdCtrls, Buttons, ExtCtrls, CommCtrl;
type
TMyCheckBox = class(TButton)
private
FCanvas: TCanvas;
IsFocused: Boolean;
FMouseInControl: Boolean;
FFocusedFrame: Boolean;
FChecked: Boolean;
FAlignment: TLeftRight;
procedure CMMouseEnter(var Message: TMessage); message CM_MOUSEENTER;
procedure CMMouseLeave(var Message: TMessage); message CM_MOUSELEAVE;
procedure SetFocusedFrame(Varue: Boolean);
procedure SetAlignment(Value: TLeftRight);
procedure MouseInFillRect(PRect: Trect; PColor: Tcolor);
procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
protected
function GetChecked: Boolean; override;
procedure SetChecked(Value: Boolean); override;
procedure CreateParams(var Params: TCreateParams); override;
procedure CreateWnd; override;
procedure SetButtonStyle(ADefault: Boolean); override;
procedure CMEnabledChanged(var Message: TMessage); message CM_ENABLEDCHANGED;
procedure CMFontChanged(var Message: TMessage); message CM_FONTCHANGED;
procedure CNMeasureItem(var Message: TWMMeasureItem ); message CN_MEASUREITEM;
procedure CNDrawItem(var Message: TWMDrawItem); message CN_DRAWITEM;
procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK;
procedure DrawButton(DrawItemStruct: TDrawItemStruct);
public
constructor Create(AOwner: TComponent); override;
destructor Destroy; override;
property Canvas: TCanvas read FCanvas;
published
property Alignment: TLeftRight read FAlignment write SetAlignment default taLeftJustify;
property Checked: Boolean read GetChecked write SetChecked default False;
property Color;
property ParentColor;
property FocusedFrame: Boolean read FFocusedFrame write SetFocusedFrame default True;
end;
procedure Register;
//////////////////////////////////////////////////////////////////////////////
implementation
uses SysUtils, Themes;
procedure Register;
begin
RegisterComponents('MyVCL', [TMyCheckBox]);
end;
constructor TMyCheckBox.Create(AOwner: TComponent);
begin
inherited Create(AOwner);
FCanvas := TCanvas.Create;
FFocusedFrame := True;
end;
destructor TMyCheckBox.Destroy;
begin
inherited Destroy;
FCanvas.Free;
end;
procedure TMyCheckBox.SetButtonStyle(ADefault: Boolean);
begin
if ADefault <> IsFocused then
begin
IsFocused := ADefault;
Refresh;
end;
end;
procedure TMyCheckBox.SetAlignment(Value: TLeftRight);
begin
if FAlignment <> Value then
begin
FAlignment := Value;
Invalidate;
end;
end;
// テーマ有効時フォーカス点々枠表示非表示設定
procedure TMyCheckBox.SetFocusedFrame(Varue: Boolean);
begin
if Varue <> FFocusedFrame then
begin
FFocusedFrame := Varue;
Refresh;
end;
end;
procedure TMyCheckBox.CreateParams(var Params: TCreateParams);
begin
inherited CreateParams(Params);
with Params do Style := Style or BS_OWNERDRAW;
end;
procedure TMyCheckBox.CNMeasureItem(var Message: TWMMeasureItem);
begin
with Message.MeasureItemStruct^ do
begin
itemWidth := Width;
itemHeight := Height;
end;
end;
procedure TMyCheckBox.CNDrawItem(var Message: TWMDrawItem);
var
SaveIndex: Integer;
begin
with Message.DrawItemStruct^ do
begin
SaveIndex := SaveDC(hDC);
FCanvas.Lock;
try
FCanvas.Handle := hDC;
FCanvas.Font := Font;
FCanvas.Brush := Brush;
DrawButton(Message.DrawItemStruct^);
finally
FCanvas.Handle := 0;
FCanvas.Unlock;
RestoreDC(hDC, SaveIndex);
end;
end;
Message.Result := 1;
end;
procedure TMyCheckBox.CMEnabledChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TMyCheckBox.CMFontChanged(var Message: TMessage);
begin
inherited;
Invalidate;
end;
procedure TMyCheckBox.WMLButtonDblClk(var Message: TWMLButtonDblClk);
begin
Perform(WM_LBUTTONDOWN, Message.Keys, Longint(Message.Pos));
end;
procedure TMyCheckBox.MouseInFillRect(PRect: Trect; PColor: Tcolor);
begin
FCanvas.Brush.Color := PColor;
FCanvas.Pen.Color := PColor;
if ThemeServices.ThemesEnabled then // テーマなら
begin
FCanvas.MoveTo(PRect.Left + 1, PRect.Top - 1);
FCanvas.LineTo(PRect.Right - 1, PRect.Top - 1);
FCanvas.MoveTo(PRect.Left + 1, PRect.Bottom);
FCanvas.LineTo(PRect.Right - 1, PRect.Bottom);
FCanvas.FillRect(PRect);
end
else
begin
PRect.Top := PRect.Top - 1;
FCanvas.FillRect(PRect);
FCanvas.MoveTo(PRect.Left, PRect.Bottom);
FCanvas.LineTo(PRect.Right, PRect.Bottom);
end;
end;
procedure TMyCheckBox.DrawButton(DrawItemStruct: TDrawItemStruct);
const
BoxSize = 13; // CHECKBOX SIZE;
var
Flags: Longint;
IsDown, IsDefault, IsDisabled: Boolean;
ORGRect, CRect, TextRect, SRect: TRect;
defCTop: integer;
defPTop, defPRight, defPBottom: integer;
BriteColor : integer;
Button : TThemedButton;
Details: TThemedElementDetails;
begin
FCanvas.Handle := DrawItemStruct.hDC;
ORGRect := ClientRect;
if (ORGRect.Right - ORGRect.Left) mod 2 = 0 then ORGRect.Right := ORGRect.Right - 1;
if (ORGRect.Bottom - ORGRect.Top) mod 2 = 0 then ORGRect.Bottom := ORGRect.Bottom - 1;
SRect := ORGRect;
SRect.Top := ORGRect.Top + 1;
SRect.Bottom := ORGRect.Bottom - 1;
defCTop := (ORGRect.Bottom - ORGRect.Top - BoxSize) div 2 + ORGRect.Top;
defPTop := (ORGRect.Bottom - ORGRect.Top - abs(FCanvas.Font.Height)) div 2 + ORGRect.Top;
defPBottom := defPTop + abs(FCanvas.Font.Height);
if FAlignment = taLeftJustify then
begin
CRect := Rect(3, defCTop, BoxSize + 3, defCTop + BoxSize);
defPRight := ORGRect.Left + BoxSize + 5 + FCanvas.TextWidth(Caption);
TextRect := Rect(ORGRect.Left + BoxSize + 5, defPTop, defPRight, defPBottom);
DrawItemStruct.rcItem.Right := DrawItemStruct.rcItem.Left + 16;
DrawItemStruct.rcItem.Left := DrawItemStruct.rcItem.Left + 1;
end
else
begin
CRect := Rect(ORGRect.Right - BoxSize - 3, defCTop, ORGRect.Right - 3, defCTop + BoxSize);
defPRight := ORGRect.Left + 2 + FCanvas.TextWidth(Caption);
TextRect := Rect(ORGRect.Left + 2, defPTop, defPRight, defPBottom);
DrawItemStruct.rcItem.Left := DrawItemStruct.rcItem.Right - 16;
end;
with DrawItemStruct do
begin
FCanvas.Handle := hdc;
FCanvas.Font := Self.Font;
IsDown := itemState and ODS_SELECTED <> 0;
IsDefault := itemState and ODS_FOCUS <> 0;
IsDisabled := itemState and ODS_DISABLED <> 0;
end;
BriteColor := Color;
if Color <> clbtnface then
begin
if BriteColor and $00FF0000 >= $00DF0000 then BriteColor := BriteColor or $00FF0000;
if BriteColor and $0000FF00 >= $0000DF00 then BriteColor := BriteColor or $0000FF00;
if BriteColor and $000000FF >= $000000DF then BriteColor := BriteColor or $000000FF;
if BriteColor and $FFFF0000 < $00DF0000 then BriteColor := BriteColor + $00200000;
if BriteColor and $FF00FF00 < $0000DF00 then BriteColor := BriteColor + $00002000;
if BriteColor and $FF0000FF < $000000DF then BriteColor := BriteColor + $00000020;
end
else BriteColor := ClWhite;
//
if ThemeServices.ThemesEnabled then // テーマなら
begin
PerformEraseBackGround(Self,Canvas.Handle);
if FChecked then
begin
if not Enabled then
Button := tbCheckBoxCheckedDisabled
else
if isDown then
Button := tbCheckBoxCheckedPressed
else
if FMouseInControl then
Button := tbCheckBoxCheckedHot
else
Button := tbCheckBoxCheckedNormal;
end
else
begin
if not Enabled then
Button := tbCheckBoxUnCheckedDisabled
else
if isDown then
Button := tbCheckBoxUnCheckedPressed
else
if FMouseInControl then
Button := tbCheckBoxUnCheckedHot
else
Button := tbCheckBoxUnCheckedNormal;
end;
Details := ThemeServices.GetElementDetails(Button);
// ThemeServices.DrawParentBackground(Handle, DrawItemStruct.hdc, @Details, True);
if FMouseInControl then
MouseInFillRect(SRect, BriteColor)
else
MouseInFillRect(SRect, Color);
ThemeServices.DrawElement(DrawItemStruct.hdc, Details, DrawItemStruct.rcItem);
end
else
begin
Flags := DFCS_BUTTONCHECK;
if IsDown then Flags := Flags or DFCS_PUSHED;
if IsDisabled then Flags := Flags or DFCS_INACTIVE;
if FChecked then Flags := Flags or DFCS_CHECKED;
if FMouseInControl then
MouseInFillRect(SRect, BriteColor)
else
MouseInFillRect(SRect, Color);
DrawFrameControl(FCanvas.Handle, CRect, DFC_BUTTON, Flags);
end;
// Caption set
if IsDisabled then
DrawState( FCanvas.Handle, FCanvas.Brush.Handle, nil, Integer(Caption), 0,
TextRect.Left,TextRect.Top, 0, 0, DST_TEXT or DSS_DISABLED)
else
DrawText(FCanvas.Handle, PChar(Caption), -1, TextRect, DT_SINGLELINE or DT_CENTER or DT_VCENTER);
// Focuse Frame Draw
if IsFocused and IsDefault and FFocusedFrame then
begin
InflateRect(ORGRect, 0, 0);
FCanvas.Pen.Color := clWindowFrame;
FCanvas.Font.Color := clBlack;
FCanvas.Brush.Color := clBtnFace;
DrawFocusRect(FCanvas.Handle, ORGRect);
end;
end;
function TMyCheckBox.GetChecked: Boolean;
begin
Result := FChecked;
Refresh;
end;
procedure TMyCheckBox.SetChecked(Value: Boolean);
begin
if FChecked <> Value then
begin
FChecked := Value;
TabStop := Value;
if HandleAllocated then
SendMessage(Handle, BM_SETCHECK, Integer(Checked), 0);
if Value then
begin
inherited Changed;
if not ClicksDisabled then Click;
end;
end;
end;
procedure TMyCheckBox.CreateWnd;
begin
inherited CreateWnd;
SendMessage(Handle, BM_SETCHECK, Integer(FChecked), 0);
end;
procedure TMyCheckBox.CNCommand(var Message: TWMCommand);
begin
case Message.NotifyCode of
BN_CLICKED: if FChecked then SetChecked(False)
else SetChecked(True);
BN_DOUBLECLICKED: DblClick;
end;
end;
procedure TMyCheckBox.CMMouseEnter(var Message: TMessage);
begin
inherited;
if not FMouseinControl and not (csDesigning in ComponentState) then
begin
FMouseInControl := True;
if Enabled then Repaint;
end;
end;
procedure TMyCheckBox.CMMouseLeave(var Message: TMessage);
begin
inherited;
if FMouseinControl then
begin
FMouseInControl := False;
if Enabled then Repaint;
end;
end;
end.
MyCheckBox.zip
コンポーネント一覧へ戻る