Package Structure

• MdClockFrame.pas
• MdSounB.pas
• MdNumEd.pas
• MdArrow.pas
• MdListAct.pas
• MdActiveBtn.pas
• MdListDial.pas
• MdClock.pas
• MdFontbox.pas

unit MdClockFrame;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  ExtCtrls, StdCtrls;

type
  TMdFramedClock = class(TFrame)
    Label1: TLabel;
    Timer1: TTimer;
    Bevel1: TBevel;
    procedure Timer1Timer(Sender: TObject);
  public
    constructor Create(AOnwer: TComponent); override;
  published
    property SubLabel: TLabel read Label1;
    property SubTimer: TTimer read Timer1;
  end;

procedure Register;

implementation

{$R *.DFM}

constructor TMdFramedClock.Create(AOnwer: TComponent);
begin
  inherited;
  Timer1.SetSubComponent (true);
  Label1.SetSubComponent (true);
end;

procedure TMdFramedClock.Timer1Timer(Sender: TObject);
begin
  Label1.Caption := TimeToStr (Time);
end;

procedure Register;
begin
  RegisterComponents ('Md', [TMdFramedClock]);
end;

end.

unit MdSounB;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  StdCtrls;

type
  TMdSoundButton = class(TButton)
  private
    FSoundUp, FSoundDown: string;
  protected
    procedure MouseDown(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
    procedure MouseUp(Button: TMouseButton;
      Shift: TShiftState; X, Y: Integer); override;
  published
    property SoundUp: string
      read FSoundUp write FSoundUp;
    property SoundDown: string
      read FSoundDown write FSoundDown;
  end;

procedure Register;

implementation

uses MMSystem;

procedure TMdSoundButton.MouseDown(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseDown (Button, Shift, X, Y);
  PlaySound (PChar (FSoundDown), 0, snd_Async);
end;

procedure TMdSoundButton.MouseUp(Button: TMouseButton;
  Shift: TShiftState; X, Y: Integer);
begin
  inherited MouseUp (Button, Shift, X, Y);
  PlaySound (PChar (FSoundUp), 0, snd_Async);
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdSoundButton]);
end;

end.

unit MdNumEd;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, StdCtrls;

type
  TMdNumEdit = class (TCustomEdit)
  private
    fInputError: TNotifyEvent;
  protected
    function GetValue: Integer;
    procedure SetValue (Value: Integer);
  public
    procedure WmChar (var Msg: TWmChar); message wm_Char;
    constructor Create (Owner: TComponent); override;
  published
    property OnInputError: TNotifyEvent
      read fInputError write fInputError;
    property Value: Integer
      read GetValue write SetValue default 0;
    property AutoSelect;
    property AutoSize;
    property BorderStyle;
    property CharCase;
    property Color;
    property Ctl3D;
    property DragCursor;
    property DragMode;
    property Enabled;
    property Font;
    property HideSelection;
    property MaxLength;
    property OEMConvert;
    property ParentColor;
    property ParentCtl3D;
    property ParentFont;
    property ParentShowHint;
    property PasswordChar;
    property PopupMenu;
    property ReadOnly;
    property ShowHint;
    property TabOrder;
    property TabStop;
    property Visible;
    property OnChange;
    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;

  TMdThousandEdit = class (TMdNumEdit)
  public
    procedure Change; override;
  end;

procedure Register;

implementation

constructor TMdNumEdit.Create (Owner: TComponent);
begin
  inherited Create (Owner);
  Value := 0;
end;

function TMdNumEdit.GetValue: Integer;
begin
  // set to 0 in case of error
  Result := StrToIntDef (Text, 0);
end;

procedure TMdNumEdit.SetValue (Value: Integer);
begin
  Text := IntToStr (Value);
end;

procedure TMdNumEdit.WmChar (var Msg: TWmChar);
begin
  if not (Char (Msg.CharCode) in ['0'..'9']) and not (Msg.CharCode = 8) then
  begin
    if Assigned (fInputError) then
      fInputError (Self);
  end
  else
    inherited;
end;

procedure Register;
begin
  RegisterComponents ('Md', [TMdNumEdit, TMdThousandEdit]);
end;

{ TMdCurrencyEdit }

function StringToFloatSkipping (s: string): Extended;
var
  s1: string;
  I: Integer;
begin
  // remove non-numbers, but keep the decimal separator
  s1 := '';
  for i := 1 to length (s) do
   if s[i] in ['0'..'9'] then
     s1 := s1 + s[i];
  Result := StrToFloat (s1);
end;

procedure TMdThousandEdit.Change;
var
  CursorPos, // original position of the cursor
  LengthDiff: Integer; // number of new separators (+ or -)
begin
  if Assigned (Parent) then
  begin
    CursorPos := SelStart;
    LengthDiff := Length (Text);
    Text := FormatFloat ('#,###',
      StringToFloatSkipping (Text));
    LengthDiff := Length (Text) - LengthDiff;
    // move the cursor to the proper position
    SelStart := CursorPos + LengthDiff;
  end;
  inherited;
end;

end.

unit MdArrow;

interface

uses
  SysUtils, Windows, Messages, Classes,
  Graphics, Controls, Forms, Dialogs;

type
  TMdArrowDir = (adUp, adLeft, adDown, adRight);

  TMdArrow = class (TGraphicControl)
  private
    fDirection: TMdArrowDir;
    fArrowHeight: Integer;
    fFilled: Boolean;
    fPen: TPen;
    fBrush: TBrush;
    fArrowDblClick: TNotifyEvent;
    fArrowPoints: array [0..3] of TPoint;
    procedure ComputePoints;
    procedure SetDirection (Value: TMdArrowDir);
    procedure SetArrowHeight (Value: Integer);
    procedure SetFilled (Value: Boolean);
    procedure SetPen (Value: TPen);
    procedure SetBrush (Value: TBrush);
    procedure RepaintRequest (Sender: TObject);
    procedure WMLButtonDblClk (var Msg: TWMLButtonDblClk);
      message wm_LButtonDblClk;
  protected
    procedure Paint; override;
    procedure ArrowDblClick; dynamic;
  public
    constructor Create (AOwner: TComponent); override;
    destructor Destroy; override;
    procedure SetBounds (ALeft, ATop, AWidth, AHeight: Integer); override;
  published
    property Width default 50;
    property Height default 20;
    property Direction: TMdArrowDir
      read fDirection write SetDirection default adRight;
    property ArrowHeight: Integer
      read fArrowHeight write SetArrowHeight default 10;
    property Filled: Boolean
      read fFilled write SetFilled default False;
    property Pen: TPen
      read fPen write SetPen;
    property Brush: TBrush
      read fBrush write SetBrush;
    property OnClick;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDrag;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnArrowDblClick: TNotifyEvent
      read fArrowDblClick write fArrowDblClick;
  end;

implementation

constructor TMdArrow.Create (AOwner: TComponent);
begin
  // call the parent constructor
  inherited Create (AOwner);

  // set the default values
  fDirection := adRight;
  Width := 50;
  Height := 20;
  fArrowHeight := 10;
  fFilled := False;

  // create the pen and the brush
  fPen := TPen.Create;
  fBrush := TBrush.Create;

  // set a handler for the OnChange event
  fPen.OnChange := RepaintRequest;
  fBrush.OnChange := RepaintRequest;
end;

destructor TMdArrow.Destroy;
begin
  // delete the two objects
  fPen.Free;
  fBrush.Free;
  // call the parent destructor
  inherited Destroy;
end;

procedure TMdArrow.SetDirection (Value: TMdArrowDir);
begin
  if fDirection <> Value then
  begin
    fDirection := Value;
    ComputePoints;
    Invalidate;
  end;
end;

procedure TMdArrow.SetArrowHeight (Value: Integer);
begin
  if fArrowHeight <> Value then
  begin
    fArrowHeight := Value;
    ComputePoints;
    Invalidate;
  end;
end;

procedure TMdArrow.SetFilled (Value: Boolean);
begin
  if fFilled <> Value then
  begin
    fFilled := Value;
    Invalidate;
  end;
end;

procedure TMdArrow.SetPen (Value: TPen);
begin
  fPen.Assign(Value);
  Invalidate;
end;

procedure TMdArrow.SetBrush (Value: TBrush);
begin
  fBrush.Assign(Value);
  Invalidate;
end;

procedure TMdArrow.RepaintRequest (Sender: TObject);
begin
  Invalidate;
end;

procedure TMdArrow.Paint;
var
  XCenter, YCenter: Integer;
begin
  // compute the center
  YCenter := (Height - 1) div 2;
  XCenter := (Width - 1) div 2;

  // use the current pen and brush
  Canvas.Pen := fPen;
  Canvas.Brush := fBrush;

  // draw the arrow line
  case fDirection of
    adUp: begin
      Canvas.MoveTo (XCenter, Height-1);
      Canvas.LineTo (XCenter, fArrowHeight);
    end;
    adDown: begin
      Canvas.MoveTo (XCenter, 0);
      Canvas.LineTo (XCenter, Height - 1 - fArrowHeight);
    end;
    adLeft: begin
      Canvas.MoveTo (Width - 1, YCenter);
      Canvas.LineTo (fArrowHeight, YCenter);
    end;
    adRight: begin
      Canvas.MoveTo (0, YCenter);
      Canvas.LineTo (Width - 1 - fArrowHeight, YCenter);
    end;
  end;

  // draw the arrow head, eventually filling it
  if fFilled then
    Canvas.Polygon (fArrowPoints)
  else
    Canvas.PolyLine (fArrowPoints);
end;

procedure TMdArrow.ArrowDblClick;
begin
  // call the handler, if available
  if Assigned (fArrowDblClick) then
    fArrowDblClick (Self);
end;

procedure TMdArrow.ComputePoints;
var
  XCenter, YCenter: Integer;
begin
  // compute the points of the arrow head
  YCenter := (Height - 1) div 2;
  XCenter := (Width - 1) div 2;

  // set the points depending on the direction
  case fDirection of
    adUp: begin
      fArrowPoints [0] := Point (0, fArrowHeight);
      fArrowPoints [1] := Point (XCenter, 0);
      fArrowPoints [2] := Point (Width-1, fArrowHeight);
      fArrowPoints [3] := Point (0, fArrowHeight);
    end;
    adDown: begin
      fArrowPoints [0] := Point (XCenter, Height - 1);
      fArrowPoints [1] := Point (0, Height - 1 - fArrowHeight);
      fArrowPoints [2] := Point (Width - 1, Height - 1 - fArrowHeight);
      fArrowPoints [3] := Point (XCenter, Height - 1);
    end;
    adLeft: begin
      fArrowPoints [0] := Point (fArrowHeight, Height - 1);
      fArrowPoints [1] := Point (0, YCenter);
      fArrowPoints [2] := Point (fArrowHeight, 0);
      fArrowPoints [3] := Point (fArrowHeight, Height - 1);
    end;
    adRight: begin
      fArrowPoints [0] := Point (Width - 1 - fArrowHeight, Height - 1);
      fArrowPoints [1] := Point (Width - 1 - fArrowHeight, 0);
      fArrowPoints [2] := Point (Width - 1, YCenter);
      fArrowPoints [3] := Point (Width - 1 - fArrowHeight, Height - 1);
    end;
  end; // case
end;

procedure TMdArrow.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds (ALeft, ATop, AWidth, AHeight);
  ComputePoints;
end;

procedure TMdArrow.WMLButtonDblClk(var Msg: TWMLButtonDblClk);
var
  HRegion: HRgn;
begin
  // perform default handling
  inherited;

  // compute the arrow head region
  HRegion := CreatePolygonRgn (
    fArrowPoints, 3, WINDING);
  try
    // check whether the click took place in the region
    if PtInRegion (HRegion, Msg.XPos, Msg.YPos) then
      ArrowDblClick;
  finally
    DeleteObject (HRegion);
  end;
end;

end.

unit MdListAct;

interface

uses
  ActnList, Classes, StdCtrls, ExtActns, Controls;

type
  TMdCustomListAction = class (TListControlAction)
  protected
    function TargetList (Target: TObject): TCustomListBox;
    function GetControl(Target: TObject): TCustomListControl;
  public
    procedure UpdateTarget (Target: TObject); override;
  published
    property Caption;
    property Enabled;
    property HelpContext;
    property Hint;
    property ImageIndex;
    property ListControl;
    property ShortCut;
    property SecondaryShortCuts;
    property Visible;
    property OnHint;
  end;

  TMdListCutAction = class (TMdCustomListAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

  TMdListCopyAction = class (TMdCustomListAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

  TMdListPasteAction = class (TMdCustomListAction)
  public
    procedure UpdateTarget (Target: TObject); override;
    procedure ExecuteTarget (Target: TObject); override;
  end;

procedure Register;

implementation

uses
  Windows, Clipbrd;

function TMdCustomListAction.GetControl(
  Target: TObject): TCustomListControl;
begin
  Result := Target as TCustomListControl;
end;

function TMdCustomListAction.TargetList (Target: TObject): TCustomListBox;
begin
  Result := GetControl (Target) as TCustomListBox;
end;

procedure TMdCustomListAction.UpdateTarget(Target: TObject);
begin
  Enabled := (TargetList (Target).Items.Count > 0)
    and (TargetList (Target).ItemIndex >= 0);
end;

procedure TMdListCopyAction.ExecuteTarget(Target: TObject);
begin
  with TargetList (Target) do
    Clipboard.AsText := Items [ItemIndex];
end;

procedure TMdListCutAction.ExecuteTarget(Target: TObject);
begin
  with TargetList (Target) do
  begin
    Clipboard.AsText := Items [ItemIndex];
    Items.Delete (ItemIndex);
  end;
end;

procedure TMdListPasteAction.ExecuteTarget(Target: TObject);
begin
  TargetList (Target).Items.Add (Clipboard.AsText);
end;

procedure TMdListPasteAction.UpdateTarget(Target: TObject);
begin
  Enabled := Clipboard.HasFormat (CF_TEXT);
end;

procedure Register;
begin
  RegisterActions ('List',
    [TMdListCutAction, TMdListCopyAction, TMdListPasteAction],
    nil);
end;

end.

unit MdActiveBtn;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TMdActiveButton = class(TButton)
  protected
    procedure MouseEnter (var Msg: TMessage);
      message cm_mouseEnter;
    procedure MouseLeave (var Msg: TMessage);
      message cm_mouseLeave;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Md', [TMdActiveButton]);
end;

{ TMdActiveButton }

procedure TMdActiveButton.MouseEnter(var Msg: TMessage);
begin
  Font.Style := Font.Style + [fsBold];
end;

procedure TMdActiveButton.MouseLeave(var Msg: TMessage);
begin
  Font.Style := Font.Style - [fsBold];
end;

end.

unit MdListDial;

interface

uses
  SysUtils, Windows, Messages, Classes,
  Graphics, Controls, Forms, Dialogs, StdCtrls,
  Buttons;

type
  TMdListDialog = class (TComponent)
  private
    FLines: TStrings;
    FSelected: Integer;
    FTitle: string;
    function GetSelItem: string;
    procedure SetLines (Value: TStrings);
    function GetLines: TStrings;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    function Execute: Boolean;
    property SelItem: string
      read GetSelItem;
  published
    property Lines: TStrings
      read GetLines write SetLines;
    property Selected: Integer
      read FSelected write FSelected;
    property Title: string
      read FTitle write FTitle;
  end;

type
  TMdListBoxForm = class(TForm)
    ListBox1: TListBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    procedure ListBox1DblClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

{$R *.DFM}

procedure Register;

implementation

// component methods

constructor TMdListDialog.Create(AOwner: TComponent);
begin
  inherited Create (AOwner);
  FLines := TStringList.Create;
  FTitle := 'Choose a string';
end;

destructor TMdListDialog.Destroy;
begin
  FLines.Free;
  inherited Destroy;
end;

function TMdListDialog.GetSelItem: string;
begin
  if (Selected >= 0) and (Selected < FLines.Count) then
    Result := FLines [Selected]
  else
    Result := '';
end;

function TMdListDialog.GetLines: TStrings;
begin
  Result := FLines;
end;

procedure TMdListDialog.SetLines (Value: TStrings);
begin
  FLines.Assign (Value);
end;

function TMdListDialog.Execute: Boolean;
var
  ListBoxForm: TMdListBoxForm;
begin
  if FLines.Count = 0 then
    raise EStringListError.Create ('No items in the list');
  ListBoxForm := TMdListBoxForm.Create (nil);
  try
    ListBoxForm.ListBox1.Items := FLines;
    ListBoxForm.ListBox1.ItemIndex := FSelected;
    ListBoxForm.Caption := FTitle;
    if ListBoxForm.ShowModal = mrOk then
    begin
      Result := True;
      Selected := ListBoxForm.ListBox1.ItemIndex;
    end
    else
      Result := False;
  finally
    ListBoxForm.Free;
  end;
end;

// form methods

procedure TMdListBoxForm.ListBox1DblClick(Sender: TObject);
begin
  ModalResult := mrOk;
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdListDialog]);
end;

end.

unit MdClock;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics,
  Controls, StdCtrls, ExtCtrls;

type
  TMdClock = class (TCustomLabel)
  private
    FTimer: TTimer;
  protected
    procedure UpdateClock (Sender: TObject);
  public
    constructor Create (AOwner: TComponent); override;
  published
    property Align;
    property Alignment;
    property Color;
    property Font;
    property ParentColor;
    property ParentFont;
    property ParentShowHint;
    property PopupMenu;
    property ShowHint;
    property Transparent;
    property Visible;
    property Timer: TTimer read FTimer;
  end;

procedure Register;

implementation

constructor TMdClock.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // create the internal timer object
  FTimer := TTimer.Create (Self);
  FTimer.Name := 'ClockTimer';
  FTimer.OnTimer := UpdateClock;
  FTimer.Enabled := True;
  FTimer.SetSubComponent (True);
end;

procedure TMdClock.UpdateClock (Sender: TObject);
begin
  // set the current time as caption
  Caption := TimeToStr (Time);
end;

procedure Register;
begin
  RegisterComponents('Md', [TMdClock]);
end;

end.

unit MdFontbox;

interface

uses
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs,
  StdCtrls;

type
  TMdFontCombo = class(TComboBox)
  private
    FChangeFormFont: Boolean;
    procedure SetChangeFormFont(const Value: Boolean);
  public
    constructor Create (AOwner: TComponent); override;
    procedure CreateWnd; override;
    procedure Change; override;
  published
    property Style default csDropDownList;
    property Items stored False;
    property ChangeFormFont: Boolean
      read FChangeFormFont write SetChangeFormFont
      default True;
  end;

procedure Register;

implementation

procedure Register;
begin
  RegisterComponents('Md', [TMdFontCombo]);
end;

{ TMdFontCombo class }

procedure TMdFontCombo.Change;
begin
  // assign the font to the owner form
  if FChangeFormFont and Assigned (Owner) and (Owner is TForm) then
    TForm (Owner).Font.Name := Text;
  inherited;
end;

constructor TMdFontCombo.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  Style := csDropDownList;
  FChangeFormFont := True;
end;

procedure TMdFontCombo.CreateWnd;
begin
  inherited CreateWnd;
  Items.Assign (Screen.Fonts);

  // grab the default font of the owner form
  if FChangeFormFont and Assigned (Owner) and (Owner is TForm) then
    ItemIndex := Items.IndexOf (
      (Owner as TForm).Font.Name);
end;

procedure TMdFontCombo.SetChangeFormFont(const Value: Boolean);
begin
  FChangeFormFont := Value;
  // refresh font
  if FChangeFormFont then
    Change;
end;

end.