Marco Cantù 1998, Mastering Delphi 4

Package: MD4PACK.DPK




Package Structure


LISTACT.PAS

unit ListAct;

interface

uses
  ActnList, Classes, StdCtrls;

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

  TListCutAction = class (TListAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

  TListCopyAction = class (TListAction)
  public
    procedure ExecuteTarget(Target: TObject); override;
  end;

  TListPasteAction = class (TListAction)
  public
    procedure UpdateTarget (Target: TObject); override;
    procedure ExecuteTarget (Target: TObject); override;
  end;

procedure Register;

implementation

uses
  Windows, Clipbrd;

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

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

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

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

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

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

procedure Register;
begin
  RegisterActions ('ListBox',
    [TListCutAction, TListCopyAction, TListPasteAction],
    nil);
end;

end.

MD4ACTIVEBTN.PAS

unit Md4ActiveBtn;

interface

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

type
  TMd4ActiveButton = 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('Md4', [TMd4ActiveButton]);
end;

{ TMd4ActiveButton }

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

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

end.

MD4TABLIST.PAS

unit Md4TabList;

interface

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

type
  TMd4TabsArray = array [0..9] of Integer;

  TMd4TabbedList = class(TListBox)
  private
    FTabStops: TMd4TabsArray;
    function GetTabStops (Index: Integer): Integer;
    procedure SetTabStops (Index, Value: Integer);
    function GetTabsString: string;
    procedure SetTabsString (Value: string);
  protected
    procedure UpdateTabStops;
  public
    procedure CreateParams (
      var Params: TCreateParams); override;
    procedure CreateWnd; override;
    property TabStops [Index: Integer]: Integer
      read GetTabStops write SetTabStops;
  published
    property TabsString: string
      read GetTabsString write SetTabsString;
  end;

procedure Register;

implementation

procedure TMd4TabbedList.CreateParams (var Params: TCreateParams);
begin
  inherited CreateParams (Params);
  Params.Style := Params.Style or lbs_UseTabStops;
end;

procedure TMd4TabbedList.CreateWnd;
var
  I: Integer;
begin
  inherited CreateWnd;
  for I := Low (FTabStops) to High (FTabStops) do
    FTabStops [I] := I * 100;
  UpdateTabStops;
end;

procedure TMd4TabbedList.SetTabStops (Index, Value: Integer);
begin
  if FTabStops [Index] <> Value then
  begin
    FTabStops [Index] := Value;
    UpdateTabStops;
    Invalidate;
  end;
end;

function TMd4TabbedList.GetTabStops (Index: Integer): Integer;
begin
  Result := FTabStops [Index];
end;

procedure TMd4TabbedList.UpdateTabStops;
var
  I: Integer;
  HUnits: Integer;
  ConvertedTabs: TMd4TabsArray;
begin
  {determine the horizontal dialog box units
  used by the list box, which depend on
  its current font}
  Canvas.Font := Font;
  HUnits := Canvas.TextWidth (
    'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz')
    div 52;

  {convert the array of tab values}
  for I := Low (ConvertedTabs) to High (ConvertedTabs) do
    ConvertedTabs [I] := FTabStops [I] * 4 div HUnits;

  {activate the tabs stops in the list box,
  sending a Windows list box message}
  SendMessage (Handle, lb_SetTabStops,
    1 + High (ConvertedTabs) - Low (ConvertedTabs),
    LongInt (@ConvertedTabs));
end;

function TMd4TabbedList.GetTabsString: string;
var
  Text: string;
  I: Integer;
begin
  Text := '';
  for I := Low (FTabStops) to High (FTabStops) do
    Text := Text + IntToStr (FTabStops [I]) + ';';
  Result := Text;
end;

procedure TMd4TabbedList.SetTabsString (Value: string);
var
  Text: string;
  I, Len : Integer;
begin
  Text := Value;
  for I := Low (FTabStops) to High (FTabStops) do
  begin
    Len := Pos (Text, ';');
    FTabStops [I] := StrToIntDef (
      Copy (Text, 1, Len), 0);
    Delete (Text, 1, Len);
  end;
  UpdateTabStops;
  Invalidate;
end;

procedure Register;
begin
  RegisterComponents('Md4', [TMd4TabbedList]);
end;

end.

MD4ARROW.PAS

unit Md4Arrow;

interface

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

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

  TMd4Arrow = class (TGraphicControl)
  private
    fDirection: TMd4ArrowDir;
    fArrowHeight: Integer;
    fFilled: Boolean;
    fPen: TPen;
    fBrush: TBrush;
    fArrowDblClick: TNotifyEvent;
    fArrowPoints: array [0..3] of TPoint;
    procedure ComputePoints;
    procedure SetDirection (Value: TMd4ArrowDir);
    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: TMd4ArrowDir
      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;

procedure Register;

implementation

{R ARROW4.DCR}

constructor TMd4Arrow.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 TMd4Arrow.Destroy;
begin
  // delete the two objects
  fPen.Free;
  fBrush.Free;
  // call the parent destructor
  inherited Destroy;
end;

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

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

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

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

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

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

procedure TMd4Arrow.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 TMd4Arrow.ArrowDblClick;
begin
  // call the handler, if available
  if Assigned (fArrowDblClick) then
    fArrowDblClick (self);
end;

procedure Register;
begin
  RegisterComponents('Md4', [TMd4Arrow]);
end;

procedure TMd4Arrow.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 TMd4Arrow.SetBounds(ALeft, ATop, AWidth, AHeight: Integer);
begin
  inherited SetBounds (ALeft, ATop, AWidth, AHeight);
  ComputePoints;
end;

procedure TMd4Arrow.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.

MD4LISTDIAL.PAS

unit Md4ListDial;

interface

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

type
  TMd4ListDialog = 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
  TMd4ListBoxForm = class(TForm)
    ListBox1: TListBox;
    BitBtn1: TBitBtn;
    BitBtn2: TBitBtn;
    Button1: TButton;
    procedure ListBox1DblClick(Sender: TObject);
  private
    { Private declarations }
  public
    { Public declarations }
  end;

{$R *.DFM}

procedure Register;

implementation

// component methods

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

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

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

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

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

function TMd4ListDialog.Execute: Boolean;
var
  ListBoxForm: TMd4ListBoxForm;
begin
  if FLines.Count = 0 then
    raise EStringListError.Create ('No items in the list');
  ListBoxForm := TMd4ListBoxForm.Create (self);
  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 TMd4ListBoxForm.ListBox1DblClick(Sender: TObject);
begin
  ModalResult := mrOk;
end;

procedure Register;
begin
  RegisterComponents('Md4', [TMd4ListDialog]);
end;

end.

MD4CLOCK.PAS

unit Md4Clock;

interface

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

type
  TMd4Clock = 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 TMd4Clock.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  // create the internal timer object
  FTimer := TTimer.Create (self);
  FTimer.OnTimer := UpdateClock;
  FTimer.Enabled := True;
end;

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

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

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

procedure Register;
begin
  RegisterComponents('Md4', [TMd4Clock]);
end;

end.

MD4FONTBOX.PAS

unit Md4Fontbox;

interface

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

type
  TMd4FontCombo = 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 TMd4FontCombo.Create (AOwner: TComponent);
begin
  inherited Create (AOwner);
  Style := csDropDownList;
end;

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

procedure Register;
begin
  RegisterComponents('Md4', [TMd4FontCombo]);
end;

end.



Copyright Marco Cantù 1998