歯제작.PDF

Transcription

1 E07

2 1, 2 VCL Visual Component Library, [1] TComponent VCL VCL, (Object) TStrings TCanvas VCL [ 1] 2

3 TObject TObject [ 1] 21 TObject TObject [ 1] TObject, TObject,,,,, (run-time type information) TObject TObject = class constructor Create; 3

4 procedure Free; class function InitInstance(Instance: Pointer): TObject; procedure CleanupInstance; function ClassType: TClass; class function ClassName: ShortString; class function ClassNameIs(const Name: string): Boolean; class function ClassParent: TClass; class function ClassInfo: Pointer; class function InstanceSize: Longint; class function InheritsFrom(AClass: TClass): Boolean; class function MethodAddress(const Name: ShortString): Pointer; class function MethodName(Address: Pointer): ShortString; function FieldAddress(const Name: ShortString): Pointer; function GetInterface(const IID: TGUID; out Obj): Boolean; class function GetInterfaceEntry(const IID: TGUID): PInterfaceEntry; class function GetInterfaceTable: PInterfaceTable; function SafeCallException(ExceptObject: TObject; ExceptAddr: Pointer): HResult; virtual; procedure AfterConstruction; virtual; procedure BeforeDestruction; virtual; procedure Dispatch(var Message); virtual; procedure DefaultHandler(var Message); virtual; class function NewInstance: TObject; virtual; procedure FreeInstance; vi rtual; destructor Destroy; virtual; (Constructor) (Destructor), private public public, TObject TObject, TObject class 4

5 TButtonClassParent; TObject, TObject TObject, 22 TPersistent TPersistent, DFM, TPersistent TPersistent TPersistent, TPersistent, TPersistent TPersistent = class(tobject) private procedure AssignError(Source: TPersistent); protected 5

6 procedure AssignTo(Dest: TPersistent); virtual; procedure DefineProperties(Filer: TFiler); virtual; function GetOwner: TPersistent; dynamic; public destructor Destroy; override; procedure Assign(Source: TPersistent); virtual; function GetNamePath: string; dynamic; DefineProperties DefineProperty TPersistent TPersistent 23 TComponent TComponent TComponent, TComponent TComponent 6

7 Var Button1 : TButton; begin Button1 := TButtonCreate(Self); // Button1Free; Create TComponent TButton ComponentState,, DBGrid type TComponentState = set of (csloading, csreading, cswriting, csdestroying, csdesigning, csancestor, csupdating, csfixups); property ComponentState: TComponentState; csdesigning csdesigning procedure TToolButtonPaint; const XorColor = $00FFD8CE; var R: TRect; begin if FToolBar = nil then Exit; if Style = tbsdivider then with Canvas do 7

8 begin R := Rect(Width div 2-1, 0, Width, Height); DrawEdge(Handle, R, EDGE_ETCHED, BF_LEFT) if csdesigning in ComponentState then { Draw separator outline } if Style in [tbsseparator, tbsdivider] then with Canvas do begin PenStyle := psdot; PenMode := pmxor; PenColor := XorColor; BrushStyle := bsclear; Rectangle(0, 0, ClientWidth, ClientHeight); end { Draw Flat button face } else if FToolBarFlat and not Down then with Canvas do begin R := Rect(0, 0, Width, Height); DrawEdge(Handle, R, BDR_RAISEDINNER, BF_RECT); TToolButton ComponentState csdesigning TComponent TComponent TComponent TComponent, TComponent 8

9 TControl TWinControl 24 TControl TControl, TControl, Caption, Visible, Top, Width, Left, Height, Enabled, Font, Color,, OnClick, OnDblClick, OnMouseMove, OnMouseDown, OnMouseUp, OnDragDrop, OnDragOver, OnEndDrag, OnStartDock, OnEndDock, OnCanResize, OnConstrainedResize, OnResize TControl protected Object Inspector TControl protected,, public published, protected, protected public published, published protected published, published protected 25 TGraphicControl TGraphicControl,, TGraphicControl TBevel, TImage, 9

10 TPaintBox, TShape, TSpeedButton, TSplitter TCustomLabel TControl,,,, TGraphicControl 26 TWinControl TWinControl A B A parent A B child, child TWinControl, TCustomControl, TButtonControl, TCustomComboBox, TCustomEdit TCustomListBox 27 Custom Custom protected protected published TCustomLabel TLabel TCustomLabel published 10

11 3 TLabel, [ 1] TButton TButton TButton1 Unit Button1; interface uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; type TButton1 = class(tbutton) private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TButton1]); 11

12 end [ 1] Component New Component [ 1] TLabel [ 2] New Component Component New Component [ 2] TLabel Ancestor type TLabel TLabel1 TMyLabel Search path OK [ 2] Unit MyLabel; 12

13 Interface Uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, StdCtrls; Type TMyLabel = class(tlabel) Private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TMyLabel]); End [ 2] TLabel RegisterComponents procedure Register; 13

14 begin RegisterComponents('Samples', [TMyLabel]);, File Save, Create Type TMyLabel = class(tlabel) Public constructor Create(AOwner: Tcomponent): override; Create constructor TMyLabelCreate(AOwner: TComponent); begin inherited Create(AOwner); Color := clblue; FontColor := clyellow; FontName := ' '; FontSize := 12; FontStyle := [fsbold, fsitalic]; 14

15 TMyLabel File New Application TButton OnClick procedure TForm1Button1Click(Sender: TObject); var MyLabelTest : TMyLabel; begin MyLabelTest := TMyLabelCreate(Self); MyLabelTestParent := Self; MyLabelTestCaption := 'MyLabel'; MyLabelTestShow; uses [ 3] [ 3] 15

16 Component Install Component Install component [ 4] Unit file name Package file name dclusr60dpk OK Package file name Yes [ 5] Samples [ 4] Install Component [ 5] File New Application TEdit TButton TMyLabel TButton OnClick procedure TForm1Button1Click(Sender: TObject); begin MyLabel1Caption := Edit1Text; 16

17 Edit TLabel 17

18 4?,,,,,, 41?, var, 1) virtual, 2)? 18

19 [ 1]? published, published, TWinControl Ctl3D protected public published Ctl3D published Type TMyComponent = class(twincontrol) Published Property Ctl3D; Numeric, character string, ( ), true published TPersistent [ 1] 19

20 3)?,, read, write write published, public count Type TMyComponent = class (TComponent) Private Fcount: Integer; // Procedure SetCount(Value: Integer); // Public Property Count: Integer read Fcount write SetCount;, private F Count 20

21 Type TMyComponent = class(tcomponent) Private FMyProperty: Boolean; Published Property MyProperty: Boolean read FMyProperty write FMyProperty; 4) virtual public, index Type TMyCalendar = class(tcustomgrid) Public Property Day: Integer index 3 read GetDateElement write SetDateElement; Property Month: Integer index 2 read GetDateElement write SetDateElement; Property Year: Integer index 1 read GetDateElement write SetDateElement; Private Function GetDateElement(Index: Integer): Integer; Procedure SetDateElement(Index: Integer; Value: Integer); 21

22 , Function TMyCalendarGetDateElement(Index: Integer): Integer; Var AYear, AMonth, ADay: Word; Begin //FDate,, AYear, AMonth, ADay DecodeDate(FDate, AYear, AMonth, ADay); Case Index of 1: Result := AYear; 2: Result := AMonth; 3: Result := ADay; else Result := -1; Function TMyCalendarSetDateElement(Index: Integer; Value: Integer); Var AYear, AMonth, ADay: Word; Begin If Value > 0 then //Value begin DecodeDate(FDate, AYear, AMonth, ADay); Case Index of 1: Ayear := Value; 2: Amonth := Value; 3: Aday := Value; else Exit; //AYear, AMonth ADay FDate FDate := EncodeDate(AYear, AMonth, ADay); 22

23 Refresh; Get Count GetCount index read,?, Set Count SetCount, index index write read write Procedure TMyComponentSetCount(Value: Integer); Begin If Value <> FCount then 23

24 Begin FCount := Value; Update; 5) Default, Nodefault Default, default Default Property Counting Boolean read GetCounting write SetCounting default True;,? 0, null, False, nodefault Property WhatIsIt string nodefault; 6), TMemo Lines, read, write 24

25 Type TMyComponent = class(tcomponent) Private Function GetMonthSeason(Index: Integer): string; Public Property MonthSeason[Index: Integer]: string read GetMonthSeason; function TMyComponentGetMonthSeason(Index: Integer): string; begin case Index of 1, 2, 12: Result := ; 35: Result := ; 68: Result := ; 911: Result := ; 7) (DFM),,, public published 25

26 ? published stored True, False,, Type TMyComponent = class(tcomponent) Protected Function StoreIt: Boolean; Public Property Important: Integer stored True; // Published Property Unimportant: Integer stored False; // Property Sometimes: Integer stored StoreIt; //, Loaded, Loaded TDatabase Loaded procedure TDatabaseLoaded; 26

27 begin inherited Loaded; try if FStreamedConnected then Open else CheckSessionName(False); except if csdesigning in ComponentState then ApplicationHandleException(Self) else raise; 42 1)? * OnClick, Button1 OnClick Button1Click, OnClick Button1Click * 27

28 Click procedure Click; dynamic; * read, write F, OnClick TNotifyEvent FOnClick OnClick Type TControl = class(tcomponent) Private FOnClick: TNotifyEvent; Protected Property OnClick: TNotifyEvent read FOnClick write FOnClick; *,, 28

29 *,, var Var OnKeyPress Type TKeyPressEvent = procedure(sender: Tobject; var Key: Char) of object; Key Procedure TForm1Edit1KeyPressed(Sender: TObject; var Key: Char); Begin Key := UpCase(Key); *, 2),, 29

30 *, OnClick, OnDragDrop, OnEndDrag, OnMouseMove, OnDblClick, OnDragOver, OnMouseDown, OnMouseUp TControl,, OnClick Click OnEndDrag DoEndDrag OnEnter, OnKeyDown, OnKeyPress, OnKeyUp, OnExit * protected, public published OnClick Type TMyControl = class(tcustomcontrol) : published property OnClick; *, Click 30

31 Procedure Click override // : procedure TMyComponentClick; begin inherited Click; // 3) *, MouseDown WM_LBUTTONDOWN MouseDown OnChange,,,, * 31

32 - (Simple notifications) :,, Sender TNotifyEvent, Click - : KeyPressed - : var, * On, *,, - :, 32

33 if Assigned(OnClick) then OnClick(Self); // if Assigned(OnClick) then OnClick(Self) else // - :, KeyPressed var Key null if Assigned(OnKeyPress) then OnKeyPress(Self, Key); if Key <> #0 then //, Key null, 43, 1) 33

34 , (exception), 2),? Copy CopyToClipboard, X, GetHorizontalPosition? 3) 34

35 ,, public protected, private, * public public public * protected protected, protected,, public, protected, public protected protected, protected * abstract VCL custom 4) 35

36 5) implementation, protected, public Type TMyComponent = class(tcontrol) Protected Procedure MakeBigger; Public Function CalculateArea: Integer; virtual; : implementation : procedure TMyComponentMakeBigger; begin Height := Height + 5; Width := Width + 5; Function TMyComponentCalculateArea: Integer; Begin Result := Width * Height; 44 36

37 (GDI) API 1)? GDI pen brush,, pen pen,, GDI, procedure TMyWindowPaint(PaintDC: HDC; var PaintInfo: TPaintStruct); var PenHandle, OldPenHandle: HPEN; BrushHandle, OldBrushHandle: HBRUSH; begin PenHandle := CreatePen(PS_SOLID, 1, RGB(0, 0, 255)); // OldPenHandle := SelectObject(PaintDC, PenHandle); //DC BrushHandle := CreateSolidBrush(RGB(255, 255, 0)); // OldBrushHandle := SelectObject(PaintDC, BrushHandle); //DC Ellipse(HDC, 10, 10, 50, 50); // 37

38 SelectObject(OldBrushHandle); // DeleteObject(BrushHandle); // SelectObject(OldPenHandle); // DeleteObject(PenHandle); // procedure TForm1FormPaint(Sender: TObject); begin with Canvas do begin PenColor := clblue; // BrushColor := clyellow; // Ellipse(10, 10, 50, 50); // 2) [ 2] MoveTo, LineTo, Rectangle, Ellipse TextOut, TextHeight, TextWidth, TextRect FillRect, FloodFill, Pen, Brush, Font Pixels Draw, StretchDraw, BrushCopy, CopyRect ; CopyMode GDI Handle [ 2] 3) 38

39 , metafile, * (Picture), (TCanvas),,, (TGraphic), metafile TImage, TIcon TMetafile, TGraphic TGraphic (TPicture) TPicture,, metafile,, picture * LoadFromFile SaveToFile LoadFromFile SaveToFile LoadFromFile procedure TForm1LoadBitmapClick(Sender: TObject); begin Image1PictureLoadFromFile( BMP ); 39

40 BMP TBitmap LoadFromFile * ( 256 ),,, TControl,,, 4),, * Paint tryfinally Type 40

41 TFancyControl = class(tgraphiccontrol) Protected Procedure Paint; override; Procedure TFancyControlPaint; Var Bitmap: TBitmap; Begin Bitmap := TBitmapCreate; Try // Finally BitmapFree; * 4 [ 3] Draw StretchDraw CopyRect BrushCopy [ 3] *,, OnChange Shape 41

42 , OnChange Type TShape = class(tgraphiccontrol) Public Procedure StyleChanged(Sender: TObject); : implementation : constructor TShapeCreate(AOwner: TComponent); begin inherited Create(AOwner); width := 65; Height := 65; FPen := TPenCreate; FPenOnChange := StyleChanged; FBrush := TBrushCreate; FBrushOnChange := StyleChanged; Procedure TShapeStyleChanged(Sender: TObject); Begin Invalidate(); 45 1) 42

43 -> MainWndProc -> WndProc -> Dispatch -> Handler VCL *, Messages word parameter long parameter wparam lparam lparamhi API Microsoft (message cracking), WM_KEYDOWN nvirtkey IKeyData wparam lparam x y lparam Hi, lo, lparamhi lparamlo XPos YPos * case,, 43

44 MainWndProc MainWndProc WndProc, HandleException MainWndProc, WndProc WndProc,, TWinControl WndProc WndProc Dispatch Dispatch Msg Dispatch Dispatch DefaultHandler 2) 44

45 *,, override message var WM_PAINT WMPaint Type TMyComponent = class( ) : procedure WMPaint(var Message: TWMPaint); message WM_PAINT; * var, Result SendMessage message (wparam, lparam ) Message TMessage *, WndProc WndProc Dispatch, WndProc Dispatch WndProc Procedure TMyControlWndProc(var Message: TMessage); 45

46 Begin // Inherited WndProc(Message); TControl WndProc Procedure TControlWndProc(var Message: TMessage); Begin : : // ( ) if (MessageMsg >= WM_MOUSEFIRST) and (MessageMsg <= WM_MOUSELAST) then if Dragging then // DragMouseMsg(TWMMouse(Message)) // Else // : // 3) * - : 1024 WM_APP WM_APP TListBox, 46

47 TComboBox, TEdit, TButton, Const WM_MYFIRSTMESSAGE = WM_APP + 400; WM_MYSECONDMESSAGE = WM_APP + 401; - :, TMessage 1 T 2 TMsgParam Msg 3 2 word 2, 4 Longint 4 Result Longint Type TWMMouse = record Msg: TMsgParam; // Keys: Word; //wparam Case Integer of //Result 0: XPos: Smallint; 1: ( YPos: Smallint); Pos: TSmallPoint; Result: Longint); * 47

48 1> protected 2> 3> 4> Message var 5> 6> inherited CM_CHANGECOLOR Const CM_CHANGECOLOR = WM_APP + 400; Type TMyComponent = class(tcontrol) : protected procedure CMChangeColor(var Message: TMessage); message CM_CHANGECOLOR; procedure TMyComponentCMChangeColor(var Message: TMessage); begin Color := MessagelParam; Inherited; 46 IDE 1) 48

49 Register, 2) DCR(Dynamic Component Resource) 24,, TMyControl ToolBox TOOLBOXDCR, TMYCONTROL 3) F1 (RTF), Microsoft Help Workshop, Help Workshop 4) * DsgnIntfpas TPropertyEditor, TPropertyEditor 49

50 [ 4] TOrdinalProperty TIntegerProperty TCharProperty TEnumProperty TFloatProperty TStringProperty TSetElementProperty TSetProperty TClassProperty TMethodProperty TComponentProperty TColorProperty TFontNameProperty TFontProperty [ 4] TOrdinalProperty Char ( ) DDEREGPAS TPropertyEditor type TDdeLinkInfoProperty = class(tpropertyeditor) public function GetAttributes: TPropertyAttributes; override; procedure Edit; override; function GetValue: string; override; * GetValue SetValue 50

51 [ 5] GetFloatValue SetFloatValue ( ) GetMethodValue SetMethodValue GetOrdValue SetOrdValue GetStrValue SetStrValue [ 5] GetValue [ 5], SetValue GetValue GetValue unknown GetValue GetValue SetValue SetValue, SetValue SetValue TIntegerProperty SetValue GetValue GetValue GetOrdValue SetValue SetOrdValue Function TIntegerPropertyGetValue: string; Begin Result := IntToStr(GetOrdValue); 51

52 Procedure TIntegerPropertySetValue(const Value: string); Var L: Longint; Begin L := StrToInt(Value); With GetTypeData(GetpropType)^ do If (L < MinValue) or (L > MaxValue) then Raise EPropertyErrorCreate(FmtLoadStr(SOutOfRange, [MinValue, MaxValue])); SetOrdValue(L); * Font Edit Edit GetValue SetValue, Edit,, Edit TColorProperty Edit procedure TColorPropertyEdit; var ColorDialog: TColorDialog; Begin ColorDialog := TColorDialogCreate(Application); Try ColorDialogColor := GetOrdValue; If ColorDialogExecute then SetOrdValue(ColorDialogColor); Finally ColorDialogFree; 52

53 *, GetAttributes GetAttributes TPropertyAttributes TPropertyAttributes [ 6] pavaluelist GetValues pasubproperties GetProperties padialog Edit pamultiselect paautoupdate SetValue pasortlist pareadonly parevertable [ 6] Color,,, TColorProperty GetAttributes Function TColorPropertyGetAttributes: TPropertyAttributes; Begin Result := [pamultiselect, padialog, pavaluelist]; * RegisterpropertyEditor RegisterPropertyEditor 4 53

54 - TypeInfo - TypeInfo(TMyComponent) nil - Register RegisterpropertyEditor Procedure Register; Begin RegisterPropertyEditor(TypeInfo(TComponent), nil,, TComponentProperty); RegisterPropertyEditor(TypeInfo(TComponentName), Tcomponent, Name, TComponentNameProperty); RegisterPropertyEditor(TypeInfo(TmenuItem), TMenu,, TmenuItemProperty); RegisterPropertyEditor TComponent TComponentProperty, RegisterPropertyEditor nil Name TMenu TMenuItem 5) 54

55 , TDefaultEditor, TDefaultEditor,,, TComponentEditor TComponentEditor Component * GetVerbCount GetVerb GetVerbCount GetVerb GetVerb shortcut &, & shortcut GetVerb GetVerbCount GetVerb Function TMyEditorGetVerbCount: Integer; Begin Result := 2; Function TMyEditorGetVerb(Index: Integer): String; Begin Case Index of 0: Result := &DoThis ; 1: Result := Do&That ; 55

56 , GetVerbCount GetVerb GetVerbCount 2 GetVerb GetVerb ExecuteVerb GetVerb ExecuteVerb ExecuteVerb Procedure TMyEditorExecuteVerb(Index: Integer); Var MySpecialDialog: TMyDialog; Begin Case Index of 0: begin MySpecialDialog := TMyDialogCreate(Application); // If MySpecialDialogExecute then //OK MyComponentFThisProperty := MySpecialDialogReturnValue; MySpecialDialogFree; 1: That; //That Edit Edit DoThis?, Edit, Font Procedure TMyEditorEdit; 56

57 Var FontDlg: TFontDialog; Begin FontDlg := TFontDialogCreate(Application); Try If FontDlgExecute then MyComponentFFontAssign(FontDlgFont); Finally FontDlgFree; TComponentEditor TDefaultEditor Edit TDefaultEditorEditProperty EditProperty Procedure TMyEditorEditproperty(PropertyEditor: TPropertyEditor; Continue, FreeEditor: Boolean) Begin If (PropertyEditorClassName = TMethodProperty ) and (PropertyEditorGetName = OnSpecialEvent ) then DefaultEditorEditProperty(PropertyEditor, Continue, FreeEditor); IDE Copy Copy TImage picture Procedure TMyComponentCopy; Var MyFormat: Word; 57

58 AData, APalette: THandle; Begin TImage(Component)PictureBitmapSaveToClipBoardFormat(MyFormat, AData, APalette); ClipBoardSetAsHandle(MyFormat, AData); RegisterComponentEditor RegisterComponentEditor TMyComponent TMyEditor RegisterComponentEditor(TMyComponent, TMyEditor); RegisterComponentEditor Register TMyComponent TMyEditor Procedure Register; Begin RegisterComponents( Miscellaneous, [TMyComponent]); RegisterComponentEditor(classes[0], TMyEditor); 6) IDE 58

59 5,,,, TCalendar 51, 1) Component New Component TCalendar unit DBCalendar; interface 59

60 uses Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, Grids, Calendar; type TDBCalendar = class(tcalendar) private { Private declarations } protected { Protected declarations } public { Public declarations } published { Published declarations } procedure Register; implementation procedure Register; begin RegisterComponents('Samples', [TDBCalendar]); end [ 3] TDBCalendar 2) ReadOnly 60

61 * ReadOnly TCalendar ReadOnly ReadOnly Type TDBCalendar = class(tcalendar) Private FReadOnly: Boolean; Public Constructor Create(AOwner: TComponent); override; Published Property ReadOnly: Boolean read FReadOnly write FReadOnly default True; : constructor TDBCalendarCreate(AOwner: TComponent); begin inherited Create(AOwner); FReadOnly := True; ReadOnly * TDBCalendar Row Col, SelectCell UpdateCalendar Row Col, SelectCell True Type TDBCalendar = class(tcalendar) Private FUpdating: Boolean; Protected Function SelectCell(ACol, ARow: Longint): Boolean; override; Public 61

62 Procedure UpdateCalendar; override; : function TDBCalendarSelectCell(ACol, ARow: Longint): Boolean; begin if (not FUpdating) and FReadOnly then Result := False else Result := inherited SelectCell(ACol, ARow); procedure TDBCalendarUpdateCalendar; begin FUpdating := True; Try Inherited UpdateCalendar; Finally FUpdating := False;,, 3) datalink TFieldDataLink, * Type TDBCalendar = class(tcalendar) Private 62

63 FDataLink: TFieldDataLink; : uses DB DBCtrls * TDBCalendar Type TDBCalendar = class(tcalendar) Private function GetDataField: string; function GetDataSource: TDataSource; procedure SetDataField(const Value: string); procedure SetDataSource(Value: TDataSource); published property DataField: string read GetDataField write SetDataField; property DataSource: TDataSource read GetDataSource write SetDataSource; : function TDBCalendarGetDataField: string; begin Result := FDataLinkFieldName; Function TDBCalendarGetDataSource: TDataSource; Begin Result := FDataLinkDataSource; Procedure TDBCalendarSetDataField(const Value: string); Begin FDataLinkFieldName := Value; 63

64 Procedure TDBCalendarSetDataSource(Value: TDataSource); Begin FDataLinkDataSource := Value; DataField DataSource, FDataLink FieldName DataSource?, * Create Destroy Type TDBCalendar = class(tcalendar) Public Constructor Create(AOwner: TComponent); override; Destructor Destroy; override; : : constructor TDBCalendarCreate(AOwner: TComponent); begin FDataLink := TFieldDataLinkCreate; //FDataLink Inherited Create(AOwner); FReadOnly := True; Destructor TDBCalendarDestroy; Begin FDataLinkFree; //FDataLink Inherited Destroy; 64

65 4) OnDataChange, OnDataChange, OnDataChange OnDataChange Type : TDBCalendar = class(tcalendar) Private Procedure DataChange(Sender: TObject); constructor TDBCalendarCreate(AOwner: TComponent); begin inherited Create(AOwner); FReadOnly := True; FDataLink := TFieldDataLinkCreate; FDataLinkOnDataChange := DataChange; // Destructor TDBCalendarDestroy; Begin FDataLinkOnDataChange := nil; // FDataLinkFree; 65

66 Inherited Destroy; Procedure TDBCalendarDataChange(Sender: TObject); Begin If FDataLinkField = nil then CalendarDate := 0 Else CalendarDate := FDataLinkFieldAsDateTime; 52,,, 1) FReadOnly ReadOnly False ReadOnly False Constructor TDBCalendarCreate(AOwner: TComponent); Begin : FReadOnly := False; : 2) Mouse-Down Key-Down 66

67 Mouse-Down(WM_LBUTTONDOWN, WM_MBUTTONDOWN, WM_RBUTTONDOWN) Key- Down(WM_KEYDOWN) * Mouse-Down Mouse-Down Type TDBCalendar = class(tcalendar) : protected procedure MouseDown(Button: TMouseButton; Shift: TShiftState; X: Integer; Y: Integer); override; : procedure TDBCalendarMouseDown(Button: TMouseButton; Shift: TShiftState; X, var MyMouseDown: TMouseEvent; Begin Y: Integer); // ReadOnly False If not ReadOnly and FDataLinkEdit then Else Inherited MouseDown(Button, Shift, X, Y) // OnMouseDown Begin MyMouseDown := OnMouseDown; If Assigned(MyMouseDown) then MyMouseDown(Self, Button, Shift, X, Y); * Key-Down Key-Down Mouse-Down 67

68 Type TDBCalendar = class(tcalendar) : protected procedure KeyDown(var Key: Word; Shift: TShiftState); override; : procedure TDBCalendarKeyDown(var Key: Word; Shift: TShiftState); var MyKeyDown: TKeyEvent; begin // ReadOnly False Key if not ReadOnly and (Key in [VK_UP, VK_DOWN, VK_LEFT, VK_RIGHT, VK_END, VK_HOME, VK_PRIOR, VK_NEXT]) and FDataLinkEdit then inherited KeyDown(Key, Shift) else // OnKeyDown begin MyKeyDown := OnKeyDown; if Assigned(MyKeyDown) then MyKeyDown(Self, Key, Shift); 3), TDBCalendar DataChange OnUpdateData OnUpdateData UpdateData Type 68

69 TDBCalendar = class(tcalendar) Private Procedure UpdateData(Sender: TObject); : procedure UpdateData(Sender: TObject); begin FDataLinkFieldAsDateTime := CalendarDate; Constructor TDBCalendarCreate(AOwner: TComponent); Begin Inherited Create(AOwner); FReadOnly := False; FDataLink := TFieldDataLinkCreate; FDataLinkOnDataChange := DataChange; FDataLinkOnUpdateData := UpdateData; 4) Change TDBCalendar Change Change OnChange, Change Type TDBCalendar = class(tcalendar) Private Procedure Change; override; : 69

70 procedure TDBCalendarChange; begin FDataLinkModified; Inherited Change; 5) CM_EXIT CM_EXIT CMExit Type TDBCalendar = class(tcalendar) Private Procedure CMExit(var Message: TWMNoParams); message CM_EXIT; : procedure TDBCalendarCMExit(var Message: TWMNoParams); begin try FDataLinkUpdateRecord; Except On Exception do SetFocus; Inherited; 70

71 71