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