Marco's Web Center

Menu for Development

Site Menu
Object Pascal Handbook
Delphi Handbooks Collection
Mastering Borland Delphi 2005
(Old) White Papers
(Old)Tools
(Old) Conferences

My Other Sites
Italian Site (www.marcocantu.it)
the delphi search

Spirit of delphi

Advertising
Home My Blog Books Object Pascal Marco

Home: Code Repository: Mastering Delphi 5

Package MDPACK.DPK

Package Structure


MDARRREG.PAS

unit MdArrReg;

interface

uses
  DsgnIntf, Classes;

type
  TArrowCategory = class (TPropertyCategory)
    class function Name: string; override;
    class function Description: string; override;
  end;

procedure Register;

implementation

uses
  MdArrow;

class function TArrowCategory.Description: string;
begin
  // optional, not displayed
  Result := 'Properties of the Mastering Delphi Arrow component';
end;

class function TArrowCategory.Name: string;
begin
  Result := 'Arrow';
end;

procedure Register;
begin
  RegisterComponents ('Md', [TMdArrow]);
  RegisterPropertyInCategory (
    TInputCategory, TMdArrow, 'OnArrowDblClick');
  RegisterPropertyInCategory (
    TArrowCategory, TMdArrow, 'Direction');
  RegisterPropertyInCategory (
    TArrowCategory, TMdArrow, 'ArrowHeight');
  RegisterPropertyInCategory (
    TArrowCategory, TMdArrow, 'Filled');
  RegisterPropertyInCategory (
    TVisualCategory, TMdArrow, 'Filled');
end;

end.

MDARROW.PAS

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

{R ARROW4.DCR}

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.

MDSOUNB.PAS

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.

MDNUMED.PAS

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;

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
    Msg.CharCode := 0;
    if Assigned (fInputError) then
      fInputError (Self);
  end;
end;

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

end.

MDLISTACT.PAS

unit MdListAct;

interface

uses
  ActnList, Classes, StdCtrls;

type
  TMdListAction = class (TAction)
  public
    function HandlesTarget (Target: TObject): Boolean; override;
    procedure UpdateTarget (Target: TObject); override;
  end;

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

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

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

procedure Register;

implementation

uses
  Windows, Clipbrd;

function TMdListAction.HandlesTarget (Target: TObject): Boolean;
begin
  Result := (Target is TListBox) and
    TListBox(Target).Focused;
end;

procedure TMdListAction.UpdateTarget(Target: TObject);
begin
  Enabled := ((Target as TListBox).Items.Count > 0) and
    ((Target as TListBox).ItemIndex >= 0);
end;

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

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

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

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

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

end.

MDACTIVEBTN.PAS

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.

MDLISTDIAL.PAS

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.

MDCLOCK.PAS

unit MdClock;

interface

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

type
  TMdClock = class (TCustomLabel)
  private
    FTimer: TTimer;
    function GetActive: Boolean;
    procedure SetActive (Value: Boolean);
  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 Active: Boolean
      read GetActive write SetActive;
  end;

procedure Register;

implementation

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

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

function TMdClock.GetActive: Boolean;
begin
  // get the status of the timer
  Result := FTimer.Enabled;
end;

procedure TMdClock.SetActive (Value: Boolean);
begin
  // change the status of the timer
  FTimer.Enabled := Value;
end;

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

end.

MDFONTBOX.PAS

unit MdFontbox;

interface

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

type
  TMdFontCombo = class(TComboBox)
  public
    constructor Create (AOwner: TComponent); override;
    procedure CreateWnd; override;
  published
    property Style default csDropDownList;
    property Items stored False;
  end;

procedure Register;

implementation

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

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

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

end.