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 6

Chapter 20 - Project XArrow

Project Structure

XArrow.dpr
library XArrow;

uses
  ComServ,
  XArrow_TLB in 'XArrow_TLB.pas',
  MdWArrowImpl1 in 'MdWArrowImpl1.pas' {MdWArrowX: CoClass},
  XAPPage in 'XAPPage.pas' {PropertyPage1: TPropertyPage},
  MdWArrow in 'MdWArrow.pas';

{$E ocx}

exports
  DllGetClassObject,
  DllCanUnloadNow,
  DllRegisterServer,
  DllUnregisterServer;

{$R *.TLB}

{$R *.RES}

begin
end.
XArrow_TLB.pas
unit XArrow_TLB;

// ************************************************************************ //
// WARNING                                                                    
// -------                                                                    
// The types declared in this file were generated from data read from a       
// Type Library. If this type library is explicitly or indirectly (via        
// another type library referring to this type library) re-imported, or the   
// 'Refresh' command of the Type Library Editor activated while editing the   
// Type Library, the contents of this file will be regenerated and all        
// manual modifications will be lost.                                         
// ************************************************************************ //

// PASTLWTR : $Revision:   1.118  $
// File generated on 4/29/2001 4:21:40 PM from Type Library described below.

// ************************************************************************  //
// Type Lib: C:\md6code\20\XArrow\XArrow.tlb (1)
// LIBID: {482B2140-4133-11D3-B9F1-00000100A27B}
// LCID: 0
// Helpfile:
// DepndLst:
//   (1) v2.0 stdole, (C:\WINDOWS\System32\stdole2.tlb)
//   (2) v4.0 StdVCL, (C:\WINDOWS\system32\stdvcl40.dll)
// ************************************************************************ //
{$TYPEDADDRESS OFF} // Unit must be compiled without type-checked pointers.
{$WARN SYMBOL_PLATFORM OFF}
{$WRITEABLECONST ON}

interface

uses ActiveX, Classes, Graphics, OleCtrls, StdVcl, Variants, Windows;



  // *********************************************************************//
// GUIDS declared in the TypeLibrary. Following prefixes are used:
//   Type Libraries     : LIBID_xxxx                                      
//   CoClasses          : CLASS_xxxx                                      
//   DISPInterfaces     : DIID_xxxx                                       
//   Non-DISP interfaces: IID_xxxx                                        
// *********************************************************************//
const
  // TypeLibrary Major and minor versions
  XArrowMajorVersion = 1;
  XArrowMinorVersion = 0;

  LIBID_XArrow: TGUID = '{482B2140-4133-11D3-B9F1-00000100A27B}';

  IID_IMdWArrowX: TGUID = '{482B2141-4133-11D3-B9F1-00000100A27B}';
  DIID_IMdWArrowXEvents: TGUID = '{482B2143-4133-11D3-B9F1-00000100A27B}';
  CLASS_MdWArrowX: TGUID = '{482B2145-4133-11D3-B9F1-00000100A27B}';

// *********************************************************************//
// Declaration of Enumerations defined in Type Library
// *********************************************************************//
// Constants for enum TxMdWArrowDir
type
  TxMdWArrowDir = TOleEnum;
const
  adUp = $00000000;
  adLeft = $00000001;
  adDown = $00000002;
  adRight = $00000003;

// Constants for enum TxMouseButton
type
  TxMouseButton = TOleEnum;
const
  mbLeft = $00000000;
  mbRight = $00000001;
  mbMiddle = $00000002;

type

// *********************************************************************//
// Forward declaration of types defined in TypeLibrary                    
// *********************************************************************//
  IMdWArrowX = interface;
  IMdWArrowXDisp = dispinterface;
  IMdWArrowXEvents = dispinterface;

// *********************************************************************//
// Declaration of CoClasses defined in Type Library                       
// (NOTE: Here we map each CoClass to its Default Interface)              
// *********************************************************************//
  MdWArrowX = IMdWArrowX;


// *********************************************************************//
// Interface: IMdWArrowX
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {482B2141-4133-11D3-B9F1-00000100A27B}
// *********************************************************************//
  IMdWArrowX = interface(IDispatch)
    ['{482B2141-4133-11D3-B9F1-00000100A27B}']
    function  Get_Direction: TxMdWArrowDir; safecall;
    procedure Set_Direction(Value: TxMdWArrowDir); safecall;
    function  Get_ArrowHeight: Integer; safecall;
    procedure Set_ArrowHeight(Value: Integer); safecall;
    function  Get_Filled: WordBool; safecall;
    procedure Set_Filled(Value: WordBool); safecall;
    function  Get_DoubleBuffered: WordBool; safecall;
    procedure Set_DoubleBuffered(Value: WordBool); safecall;
    function  Get_Enabled: WordBool; safecall;
    procedure Set_Enabled(Value: WordBool); safecall;
    function  Get_Visible: WordBool; safecall;
    procedure Set_Visible(Value: WordBool); safecall;
    function  Get_Cursor: Smallint; safecall;
    procedure Set_Cursor(Value: Smallint); safecall;
    function  Get_FillColor: Integer; safecall;
    procedure Set_FillColor(Value: Integer); safecall;
    function  Get_PenColor: Integer; safecall;
    procedure Set_PenColor(Value: Integer); safecall;
    property Direction: TxMdWArrowDir read Get_Direction write Set_Direction;
    property ArrowHeight: Integer read Get_ArrowHeight write Set_ArrowHeight;
    property Filled: WordBool read Get_Filled write Set_Filled;
    property DoubleBuffered: WordBool read Get_DoubleBuffered write Set_DoubleBuffered;
    property Enabled: WordBool read Get_Enabled write Set_Enabled;
    property Visible: WordBool read Get_Visible write Set_Visible;
    property Cursor: Smallint read Get_Cursor write Set_Cursor;
    property FillColor: Integer read Get_FillColor write Set_FillColor;
    property PenColor: Integer read Get_PenColor write Set_PenColor;
  end;

// *********************************************************************//
// DispIntf:  IMdWArrowXDisp
// Flags:     (4416) Dual OleAutomation Dispatchable
// GUID:      {482B2141-4133-11D3-B9F1-00000100A27B}
// *********************************************************************//
  IMdWArrowXDisp = dispinterface
    ['{482B2141-4133-11D3-B9F1-00000100A27B}']
    property Direction: TxMdWArrowDir dispid 1;
    property ArrowHeight: Integer dispid 2;
    property Filled: WordBool dispid 3;
    property DoubleBuffered: WordBool dispid 4;
    property Enabled: WordBool dispid -514;
    property Visible: WordBool dispid 13;
    property Cursor: Smallint dispid 14;
    property FillColor: Integer dispid 20;
    property PenColor: Integer dispid 21;
  end;

// *********************************************************************//
// DispIntf:  IMdWArrowXEvents
// Flags:     (4096) Dispatchable
// GUID:      {482B2143-4133-11D3-B9F1-00000100A27B}
// *********************************************************************//
  IMdWArrowXEvents = dispinterface
    ['{482B2143-4133-11D3-B9F1-00000100A27B}']
    procedure OnClick; dispid 1;
    procedure OnArrowDblClick; dispid 8;
  end;


// *********************************************************************//
// OLE Control Proxy class declaration
// Control Name     : TMdWArrowX
// Help String      : MdWArrowX Control
// Default Interface: IMdWArrowX
// Def. Intf. DISP? : No
// Event   Interface: IMdWArrowXEvents
// TypeFlags        : (34) CanCreate Control
// *********************************************************************//
  TMdWArrowX = class(TOleControl)
  private
    FOnClick: TNotifyEvent;
    FOnArrowDblClick: TNotifyEvent;
    FIntf: IMdWArrowX;
    function  GetControlInterface: IMdWArrowX;
  protected
    procedure CreateControl;
    procedure InitControlData; override;
  public
    property  ControlInterface: IMdWArrowX read GetControlInterface;
    property  DefaultInterface: IMdWArrowX read GetControlInterface;
    property DoubleBuffered: WordBool index 4 read GetWordBoolProp write SetWordBoolProp;
    property Enabled: WordBool index -514 read GetWordBoolProp write SetWordBoolProp;
    property Visible: WordBool index 13 read GetWordBoolProp write SetWordBoolProp;
  published
    property  TabStop;
    property  Align;
    property  DragCursor;
    property  DragMode;
    property  ParentShowHint;
    property  PopupMenu;
    property  ShowHint;
    property  TabOrder;
    property  OnDragDrop;
    property  OnDragOver;
    property  OnEndDrag;
    property  OnEnter;
    property  OnExit;
    property  OnStartDrag;
    property Direction: TOleEnum index 1 read GetTOleEnumProp write SetTOleEnumProp stored False;
    property ArrowHeight: Integer index 2 read GetIntegerProp write SetIntegerProp stored False;
    property Filled: WordBool index 3 read GetWordBoolProp write SetWordBoolProp stored False;
    property Cursor: Smallint index 14 read GetSmallintProp write SetSmallintProp stored False;
    property FillColor: Integer index 20 read GetIntegerProp write SetIntegerProp stored False;
    property PenColor: Integer index 21 read GetIntegerProp write SetIntegerProp stored False;
    property OnClick: TNotifyEvent read FOnClick write FOnClick;
    property OnArrowDblClick: TNotifyEvent read FOnArrowDblClick write FOnArrowDblClick;
  end;

procedure Register;

resourcestring
  dtlServerPage = 'Servers';

implementation

uses ComObj;

procedure TMdWArrowX.InitControlData;
const
  CEventDispIDs: array [0..1] of DWORD = (
    $00000001, $00000008);
  CControlData: TControlData2 = (
    ClassID: '{482B2145-4133-11D3-B9F1-00000100A27B}';
    EventIID: '{482B2143-4133-11D3-B9F1-00000100A27B}';
    EventCount: 2;
    EventDispIDs: @CEventDispIDs;
    LicenseKey: nil (*HR:$00000000*);
    Flags: $00000008;
    Version: 401);
begin
  ControlData := @CControlData;
  TControlData2(CControlData).FirstEventOfs := Cardinal(@@FOnClick) - Cardinal(Self);
end;

procedure TMdWArrowX.CreateControl;

  procedure DoCreate;
  begin
    FIntf := IUnknown(OleObject) as IMdWArrowX;
  end;

begin
  if FIntf = nil then DoCreate;
end;

function TMdWArrowX.GetControlInterface: IMdWArrowX;
begin
  CreateControl;
  Result := FIntf;
end;

procedure Register;
begin
  RegisterComponents('ActiveX',[TMdWArrowX]);
end;

end.
MdWArrowImpl1.pas
unit MdWArrowImpl1;

interface

uses
  Windows, ActiveX, Classes, Controls, Graphics, Menus, Forms, StdCtrls,
  ComServ, StdVCL, AXCtrls, XArrow_TLB, MdWArrow;

{$WARN SYMBOL_PLATFORM OFF}

type
  TMdWArrowX = class(TActiveXControl, IMdWArrowX)
  private
    { Private declarations }
    FDelphiControl: TMdWArrow;
    FEvents: IMdWArrowXEvents;
    procedure ArrowDblClickEvent(Sender: TObject);
    procedure ClickEvent(Sender: TObject);
  protected
    { Protected declarations }
    procedure DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage); override;
    procedure EventSinkChanged(const EventSink: IUnknown); override;
    procedure InitializeControl; override;
    function Get_ArrowHeight: Integer; safecall;
    function Get_Cursor: Smallint; safecall;
    function Get_Direction: TxMdWArrowDir; safecall;
    function Get_DoubleBuffered: WordBool; safecall;
    function Get_Enabled: WordBool; safecall;
    function Get_Filled: WordBool; safecall;
    function Get_Visible: WordBool; safecall;
    procedure Set_ArrowHeight(Value: Integer); safecall;
    procedure Set_Cursor(Value: Smallint); safecall;
    procedure Set_Direction(Value: TxMdWArrowDir); safecall;
    procedure Set_DoubleBuffered(Value: WordBool); safecall;
    procedure Set_Enabled(Value: WordBool); safecall;
    procedure Set_Filled(Value: WordBool); safecall;
    procedure Set_Visible(Value: WordBool); safecall;
    function Get_FillColor: Integer; safecall;
    procedure Set_FillColor(Value: Integer); safecall;
    function Get_PenColor: Integer; safecall;
    procedure Set_PenColor(Value: Integer); safecall;
  end;

implementation

uses ComObj, XAPPage;

{ TMdWArrowX }

procedure TMdWArrowX.DefinePropertyPages(DefinePropertyPage: TDefinePropertyPage);
begin
  DefinePropertyPage(Class_PropertyPage1);
end;

procedure TMdWArrowX.EventSinkChanged(const EventSink: IUnknown);
begin
  FEvents := EventSink as IMdWArrowXEvents;
end;

procedure TMdWArrowX.InitializeControl;
begin
  FDelphiControl := Control as TMdWArrow;
  FDelphiControl.OnArrowDblClick := ArrowDblClickEvent;
  FDelphiControl.OnClick := ClickEvent;
end;

function TMdWArrowX.Get_ArrowHeight: Integer;
begin
  Result := FDelphiControl.ArrowHeight;
end;

function TMdWArrowX.Get_Cursor: Smallint;
begin
  Result := Smallint(FDelphiControl.Cursor);
end;

function TMdWArrowX.Get_Direction: TxMdWArrowDir;
begin
  Result := Ord(FDelphiControl.Direction);
end;

function TMdWArrowX.Get_DoubleBuffered: WordBool;
begin
  Result := FDelphiControl.DoubleBuffered;
end;

function TMdWArrowX.Get_Enabled: WordBool;
begin
  Result := FDelphiControl.Enabled;
end;

function TMdWArrowX.Get_Filled: WordBool;
begin
  Result := FDelphiControl.Filled;
end;

function TMdWArrowX.Get_Visible: WordBool;
begin
  Result := FDelphiControl.Visible;
end;

procedure TMdWArrowX.ArrowDblClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnArrowDblClick;
end;

procedure TMdWArrowX.ClickEvent(Sender: TObject);
begin
  if FEvents <> nil then FEvents.OnClick;
end;

procedure TMdWArrowX.Set_ArrowHeight(Value: Integer);
begin
  FDelphiControl.ArrowHeight := Value;
end;

procedure TMdWArrowX.Set_Cursor(Value: Smallint);
begin
  FDelphiControl.Cursor := TCursor(Value);
end;

procedure TMdWArrowX.Set_Direction(Value: TxMdWArrowDir);
begin
  FDelphiControl.Direction := TMdWArrowDir(Value);
end;

procedure TMdWArrowX.Set_DoubleBuffered(Value: WordBool);
begin
  FDelphiControl.DoubleBuffered := Value;
end;

procedure TMdWArrowX.Set_Enabled(Value: WordBool);
begin
  FDelphiControl.Enabled := Value;
end;

procedure TMdWArrowX.Set_Filled(Value: WordBool);
begin
  FDelphiControl.Filled := Value;
end;

procedure TMdWArrowX.Set_Visible(Value: WordBool);
begin
  FDelphiControl.Visible := Value;
end;

function TMdWArrowX.Get_FillColor: Integer;
begin
  Result := ColorToRGB (FDelphiControl.Brush.Color);
end;

procedure TMdWArrowX.Set_FillColor(Value: Integer);
begin
  FDelphiControl.Brush.Color := Value;
end;

function TMdWArrowX.Get_PenColor: Integer;
begin
  Result := ColorToRGB (FDelphiControl.Pen.Color);
end;

procedure TMdWArrowX.Set_PenColor(Value: Integer);
begin
  FDelphiControl.Pen.Color := Value;
end;

initialization
  TActiveXControlFactory.Create(
    ComServer,
    TMdWArrowX,
    TMdWArrow,
    Class_MdWArrowX,
    1,
    '',
    0,
    tmApartment);
end.
XAPPage.pas
unit XAPPage;

interface

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls, StdCtrls,
  ExtCtrls, Forms, ComServ, ComObj, StdVcl, AxCtrls, ColorGrd, ComCtrls,
  Dialogs;

type
  TPropertyPage1 = class(TPropertyPage)
    ComboDir: TComboBox;
    Label1: TLabel;
    Label2: TLabel;
    EditHeight: TEdit;
    UpDownHeight: TUpDown;
    Label3: TLabel;
    ShapePen: TShape;
    ShapePoint: TShape;
    Label4: TLabel;
    ButtonPen: TButton;
    ButtonPoint: TButton;
    ColorDialog1: TColorDialog;
    CheckFilled: TCheckBox;
    procedure ButtonPenClick(Sender: TObject);
    procedure ButtonPointClick(Sender: TObject);
  private
    { Private declarations }
  public
    procedure UpdatePropertyPage; override;
    procedure UpdateObject; override;
  end;

const
  Class_PropertyPage1: TGUID = '{CDA51561-914A-11D0-98D0-444553540000}';

implementation

{$R *.DFM}

procedure TPropertyPage1.UpdatePropertyPage;
begin
  { Update your controls from OleObject }
  ComboDir.ItemIndex := OleObject.Direction;
  CheckFilled.Checked := OleObject.Filled;
  EditHeight.Text := IntToStr (OleObject.ArrowHeight);
  ShapePen.Brush.Color := OleObject.PenColor;
  ShapePoint.Brush.Color := OleObject.FillColor;
end;

procedure TPropertyPage1.UpdateObject;
begin
  { Update OleObject from your controls }
  OleObject.Direction := ComboDir.ItemIndex;
  OleObject.Filled := CheckFilled.Checked;
  OleObject.ArrowHeight := UpDownHeight.Position;
  OleObject.PenColor := ColorToRGB (ShapePen.Brush.Color);
  OleObject.FillColor := ColorToRGB (ShapePoint.Brush.Color);
end;

procedure TPropertyPage1.ButtonPenClick(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    Color := ShapePen.Brush.Color;
    if Execute then
    begin
      ShapePen.Brush.Color := Color;
      Modified; // enable Apply button!
    end;
  end;
end;

procedure TPropertyPage1.ButtonPointClick(Sender: TObject);
begin
  with ColorDialog1 do
  begin
    Color := ShapePoint.Brush.Color;
    if Execute then
    begin
      ShapePoint.Brush.Color := Color;
      Modified; // enable Apply button!
    end;
  end;
end;

initialization
  TActiveXPropertyPageFactory.Create(
    ComServer,
    TPropertyPage1,
    Class_PropertyPage1);
end.
MdWArrow.pas
unit MdWArrow;

interface

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

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

  TMdWArrow = class (TCustomControl)
  private
    fDirection: TMdWArrowDir;
    fArrowHeight: Integer;
    fFilled: Boolean;
    fPen: TPen;
    fBrush: TBrush;
    fArrowDblClick: TNotifyEvent;
    fArrowPoints: array [0..3] of TPoint;
    procedure ComputePoints;
    procedure SetDirection (Value: TMdWArrowDir);
    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: TMdWArrowDir
      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 TMdWArrow.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 TMdWArrow.Destroy;
begin
  // delete the two objects
  fPen.Free;
  fBrush.Free;
  // call the parent destructor
  inherited Destroy;
end;

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

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

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

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

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

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

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

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

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

procedure TMdWArrow.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.
XAPPage.dfm
object PropertyPage1: TPropertyPage1
  Left = 297
  Top = 166
  Width = 300
  Height = 199
  Caption = 'XArrow properties'
  Color = clBtnFace
  Font.Charset = ANSI_CHARSET
  Font.Color = clBlack
  Font.Height = -13
  Font.Name = 'Arial'
  Font.Style = []
  OldCreateOrder = True
  PixelsPerInch = 96
  TextHeight = 16
  object Label1: TLabel
    Left = 24
    Top = 16
    Width = 55
    Height = 16
    Caption = 'Direction:'
  end
  object Label2: TLabel
    Left = 109
    Top = 48
    Width = 78
    Height = 16
    Caption = 'Arrow Height:'
  end
  object Label3: TLabel
    Left = 24
    Top = 96
    Width = 59
    Height = 16
    Caption = 'Pen color:'
  end
  object ShapePen: TShape
    Left = 152
    Top = 88
    Width = 33
    Height = 33
  end
  object ShapePoint: TShape
    Left = 152
    Top = 128
    Width = 33
    Height = 33
  end
  object Label4: TLabel
    Left = 24
    Top = 136
    Width = 101
    Height = 16
    Caption = 'Arrow point color:'
  end
  object ComboDir: TComboBox
    Left = 88
    Top = 13
    Width = 167
    Height = 24
    Style = csDropDownList
    ItemHeight = 16
    TabOrder = 0
    Items.Strings = (
      'adUp (0)'
      'adLeft (1)'
      'adDown (2)'
      'adRight (3)')
  end
  object EditHeight: TEdit
    Left = 194
    Top = 45
    Width = 46
    Height = 24
    ReadOnly = True
    TabOrder = 1
    Text = '10'
  end
  object UpDownHeight: TUpDown
    Left = 240
    Top = 45
    Width = 15
    Height = 24
    Associate = EditHeight
    Min = 0
    Position = 10
    TabOrder = 2
    Wrap = False
  end
  object ButtonPen: TButton
    Left = 192
    Top = 92
    Width = 64
    Height = 25
    Caption = 'New...'
    TabOrder = 3
    OnClick = ButtonPenClick
  end
  object ButtonPoint: TButton
    Left = 192
    Top = 131
    Width = 66
    Height = 25
    Caption = 'New...'
    TabOrder = 4
    OnClick = ButtonPointClick
  end
  object CheckFilled: TCheckBox
    Left = 24
    Top = 48
    Width = 65
    Height = 17
    Caption = 'Filled'
    TabOrder = 5
  end
  object ColorDialog1: TColorDialog
    Ctl3D = True
    Left = 96
    Top = 72
  end
end