Delphi Developer's Kit 1996/Delphi Developer's Kit 1996.iso/power/transpar/trnsrad.pas

Pascal/Delphi Source File | 1995-12-22 | 8.0 KB | 315 lines

{ THIS IS MY FIRST ATTEMPT AT A COMPOENENT, IT IS A TRANSPARENT
  RADIO BUTTON WITH COLOR OPTIONS.

  Sgt Galen Smallen
  EIelson AFBm, AK
}

unit Transrad;

interface

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, ExtCtrls, Menus;

type
  TTransRadioButton = class(TCustomControl)
  private
    FDown:Boolean;
    FCheckedColor:TColor;
    FGroupIndex:Byte;
    FChecked: Boolean;
    procedure TurnSiblingsOff;
    function GetTransparent: Boolean;
    Procedure SetTransparent(Value: Boolean);
    procedure WMSetFocus(var Message: TWMSetFocus); message WM_SETFOCUS;
    procedure CMCtl3DChanged(var Message: TMessage); message CM_CTL3DCHANGED;
    procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR;
    procedure CNCommand(var Message: TWMCommand); message CN_COMMAND;
  protected
    procedure SetDown(Value:Boolean);
    procedure SetCheckedColor(Value:TColor);
    constructor Create(AOwner: TComponent); override;
    procedure SetChecked(Value: Boolean);
    procedure Paint; override;
    procedure MouseDown(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton; Shift: TShiftState;
      X, Y: Integer); override;
    procedure DoEnter; override;
    procedure DoExit; override;
    function  GetCaption: TCaption;
    procedure SetCaption(const Value:TCaption);
    procedure CreateWnd; override;

  public
    property canvas;
  published
    property Caption: TCaption read GetCaption write SetCaption;
    property CheckedOnColor:TColor read FCheckedColor write SetCheckedColor
             default clbtnShadow;
    property Checked: Boolean read FChecked write SetChecked default False;
    property Ctl3d;
    property Down:Boolean read FDown write SetDown default False;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property GroupIndex:Byte read FGroupIndex write FGroupIndex
      default 0;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Transparency: Boolean Read GetTransparent Write SetTransParent default True;
    property Visible;
    property OnClick;
    property OnDblClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
  end;

procedure Register;

implementation

const bw=12;

procedure Register;
begin
  RegisterComponents('NewTools', [TTransRadioButton]);
end;
constructor TTransRadioButton.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Width := 150;
  Height := 17;
end;

procedure TTransRadioButton.TurnSiblingsOff;

var i:Integer;
    Sibling: TTransRadioButton;

begin
     if Parent <> nil then
       for i:=0 to Parent.ControlCount-1 do
         if Parent.Controls[i] is TTransRadioButton then
           begin
             Sibling:=TTransRadioButton(Parent.Controls[i]);
             if (Sibling<>Self) and
                (Sibling.GroupIndex=GroupIndex) then
                  Sibling.SetChecked(False);
           end;
end;

function TTransRadioButton.GetTransparent: Boolean;
begin
  Result := not (csOpaque in ControlStyle);
end;

procedure TTransRadioButton.SetTransparent(Value: Boolean);
begin
  if Transparency <> Value then
  begin
    if Value then
      ControlStyle := ControlStyle - [csOpaque] else
      ControlStyle := ControlStyle + [csOpaque];
    Invalidate;
  end;
end;

procedure TTransRadioButton.Paint;
var
  H: Integer;
  R: TRect;
  C: array [Byte] of Char;
  CLen: Integer;
  BL,BT,BR,BB,BM:Integer;
    TX,TY,TW,TH:Integer;
    CX,CY:Integer;
    BRect:TRect;
begin
     Canvas.Font:=Font;
     with Canvas do
       begin
         BM:=12 div 2;
         BT:=(Height div 2)-BM;
         BB:=BT+12;
         BL:=1;
         BR:= 12+1;
         if not FDOWN then
           begin
             Pen.Color:= clbtnShadow;
             Arc(BL,BT,BR,BB,BR,BT,BL,BB);
             Pen.Color:= clbtnHighlight;
             Arc(BL,BT,BR,BB,BL,BB,BR,BT);
             Pen.Color:= clBlack;
             Brush.Color := clBtnFace;
             Ellipse(BL+2,Bt+2,BR-2,BB-2);
             end
         else
           begin
             if Checked then Pen.Color:= ClbtnShadow
                        else Pen.Color:= ClbtnHighlight;
             Arc(BL,BT,BR,BB,BR,BT,BL,BB);
             if Checked then Pen.Color:= ClbtnHighlight
                        else Pen.Color:= ClbtnShadow;
             Arc(BL,BT,BR,BB,BL,BB,BR,BT);
           end;
         if Checked then
            begin
              Pen.Color:= CheckedOnColor;
              Brush.Color := CheckedOnColor;
              Ellipse(BL+2,BT+2,BR-2,BB-2);
            end;
            Brush.Color := clBtnFace;
         TX:=BR+5;
         TY:=(Height div 2)+(Font.Height div 2)-1;
         if Transparency then
         begin
         SetBkMode(Handle,TRANSPARENT);
         SetBkColor(Handle,Font.Color);
         end;
         SetTextColor(Handle,Font.Color);
         TW:=TextWidth(Caption);
         TH:=TextHeight(Caption);
         TextOut(TX,TY,Caption);
         BRect:=Bounds(TX-1,TY,TW+3,TH+1);
         DrawText(Handle, C, CLen, R, DT_LEFT or DT_SINGLELINE);
     end;
end;
procedure TTransRadioButton.SetDown(Value:Boolean);

begin
     if FDown<>Value then
       begin
         FDown:=Value;
         Paint;
       end;
end;
procedure TTransRadioButton.DoEnter;

begin
     inherited DoEnter;
     Checked:=True;
     Paint;
end;

procedure TTransRadioButton.DoExit;

begin
     inherited DoExit;
     Checked := False;
     Paint;
end;

procedure TTransRadioButton.MouseDown(Button: TMouseButton; Shift: TShiftState;
                                  X, Y: Integer);

begin
     inherited MouseDown(Button, Shift, X, Y);
     Down:=True;
end;

procedure TTransRadioButton.MouseUp(Button: TMouseButton; Shift: TShiftState;
                                  X, Y: Integer);

begin
     Down:=False;
     if (X>=0) and (X<=Width) and (Y>=0) and (Y<=Height)
       and not Checked then Checked:=True;
     inherited MouseUp(Button, Shift, X, Y);
end;
function TTransRadioButton.GetCaption:TCaption;

var Len:Integer;

begin
     Len := GetTextBuf(@Result, 256);
     Move(Result[0], Result[1], Len);
     Result[0] := Char(Len);
end;

procedure TTransRadioButton.SetCaption(const Value:TCaption);

var Buffer: array[0..255] of Char;

begin
     if GetCaption <> Value then
       SetTextBuf(StrPCopy(Buffer,Value));
     Invalidate;
end;

procedure TTransRadioButton.SetChecked(Value: Boolean);

begin
     if FChecked <> Value then
       begin
         TabStop:=Value;
         FChecked:=Value;
         if Value then
           begin
             TurnSiblingsOff;
             Click;
           end;
         Paint;
       end;
end;

procedure TTransRadioButton.SetCheckedColor(Value:TColor);

begin
     FCheckedColor:=Value;
     Paint;
end;

procedure TTransRadioButton.CreateWnd;
begin
  inherited CreateWnd;
  SendMessage(Handle, BM_SETCHECK, Cardinal(FChecked), 0);
  if Ctl3D and (Ctl3DBtnWndProc <> nil) then
    DefWndProc := Ctl3DBtnWndProc;
end;
procedure TTransRadioButton.WMSetFocus(var Message: TWMSetFocus);
begin
  if Ctl3D and (Ctl3DBtnWndProc <> nil) then UpdateWindow(Handle);
  inherited;
end;

procedure TTransRadioButton.CMCtl3DChanged(var Message: TMessage);
begin
  RecreateWnd;
end;

procedure TTransRadioButton.CMDialogChar(var Message: TCMDialogChar);
begin
  with Message do
    if IsAccel(Message.CharCode, Caption) and CanFocus then
    begin
      SetFocus;
      Result := 1;
    end else
      inherited;
end;

procedure TTransRadioButton.CNCommand(var Message: TWMCommand);
begin
  case Message.NotifyCode of
    BN_CLICKED: SetChecked(True);
    BN_DOUBLECLICKED: DblClick;
  end;
end;

end.