1{ $Id: dbctrls.pp 64623 2021-02-19 02:18:02Z martin $} 2{ 3 /*************************************************************************** 4 DbCtrls.pp 5 ---------- 6 An interface to DB aware Controls 7 Initial Revision : Sun Sep 14 2003 8 9 10 ***************************************************************************/ 11 12 ***************************************************************************** 13 This file is part of the Lazarus Component Library (LCL) 14 15 See the file COPYING.modifiedLGPL.txt, included in this distribution, 16 for details about the license. 17 ***************************************************************************** 18} 19{ 20@abstract(common db aware controls, as in Delphi) 21@author(Andrew Johnson <acjgenius@@earthlink.net>) 22@created(Sun Sep 14 2003) 23@lastmod($Date: 2021-02-19 03:18:02 +0100 (Fr, 19 Feb 2021) $) 24} 25unit DBCtrls; 26 27{$mode objfpc} 28{$H+} 29 30interface 31 32uses 33 Types, Classes, SysUtils, DB, Variants, 34 // LazUtils 35 LazTracer, LazUtilities, 36 // LCL 37 LCLStrConsts, LMessages, LCLType, LCLIntf, LResources, GraphType, Controls, Graphics, 38 Dialogs, StdCtrls, Buttons, MaskEdit, ExtCtrls, Calendar, ImgList; 39 40Type 41 { TFieldDataLink } 42 43 TFieldDataLink = class(TDataLink) 44 private 45 FField: TField; 46 FFieldName: string; 47 FControl: TComponent; 48 // Callbacks 49 FOnDataChange: TNotifyEvent; 50 FOnEditingChange: TNotifyEvent; 51 FOnUpdateData: TNotifyEvent; 52 FOnActiveChange: TNotifyEvent; 53 // Curent State of Affairs 54 FEditing: Boolean; 55 FEditingSourceSet: boolean; 56 FEditingSource: Boolean; 57 IsModified: Boolean; 58 function FieldCanModify: boolean; 59 function IsKeyField(aField: TField): Boolean; 60 function GetCanModify: Boolean; 61 // set current field 62 procedure SetFieldName(const Value: string); 63 procedure UpdateField; 64 // make sure the field/fieldname is valid before we do stuff with it 65 procedure ValidateField; 66 procedure ResetEditingSource; 67 protected 68 // Testing Events 69 procedure ActiveChanged; override; 70 procedure EditingChanged; override; 71 procedure LayoutChanged; override; 72 procedure RecordChanged(aField: TField); override; 73 procedure UpdateData; override; 74 75 procedure FocusControl(aField: TFieldRef); Override; 76 public 77 constructor Create; 78 // for control intitiating db changes etc 79 function Edit: Boolean; 80 81 procedure Modified; 82 procedure Reset; 83 84 // Attached control 85 property Control: TComponent read FControl write FControl; 86 87 // Basic DB interfaces 88 property Field: TField read FField; 89 property FieldName: string read FFieldName write SetFieldName; 90 91 // Current State of DB 92 property CanModify: Boolean read GetCanModify; 93 property Editing: Boolean read FEditing; 94 property EditingSource: boolean read FEditingSource; 95 96 // Our Callbacks 97 property OnDataChange: TNotifyEvent read FOnDataChange write FOnDataChange; 98 property OnEditingChange: TNotifyEvent read FOnEditingChange write FOnEditingChange; 99 property OnUpdateData: TNotifyEvent read FOnUpdateData write FOnUpdateData; 100 property OnActiveChange: TNotifyEvent read FOnActiveChange write FOnActiveChange; 101 end; 102 103 104 105 { TDBLookup } 106 { 107 TDBLookup component is typically owned by a Lookup control like 108 TDBLookupListBox or TDBLookupComboBox. 109 The ListSource is the other dataset TDataSource from which to retrieve the lookup data 110 The KeyField is the lookup key in the ListSource which corresponds to the DataField value 111 The ListField is the name of the field in the ListSource to list into the 112 Items property of the lookup control. 113 which data 114 } 115 116 TDBLookup = class(TComponent) 117 private 118 FControlLink: TFieldDataLink; 119 FControlItems: TStrings; 120 FListLink: TDataLink; 121 FListSource: TDataSource; 122 FLookupSource: TDataSource; 123 FDataFieldNames: string; 124 FKeyFieldNames: string; 125 FListFieldName: string; 126 FListFieldIndex: Integer; 127 FDataFields: TList; // Data Fields to lookup/edit 128 FKeyFields: TList; // Keyfields in lookup dataset 129 FListField: TField; // Result field in lookup dataset 130 FListKeys: array of Variant; 131 FNullValueKey: TShortcut; 132 FHasLookUpField: Boolean; 133 FLookUpFieldIsCached: Boolean; 134 FLookupCache: Boolean; 135 FInitializing: Boolean; 136 {$IF FPC_FULLVERSION < 30000} 137 FFetchingLookupData: Boolean; 138 {$ENDIF} 139 procedure ActiveChange(Sender: TObject); 140 procedure DatasetChange(Sender: TObject); 141 procedure DoInitialize; 142 procedure FetchLookupData; 143 function GetKeyFieldName: string; 144 function GetListSource: TDataSource; 145 procedure SetKeyFieldName(const Value: string); 146 procedure SetListFieldName(const Value: string); 147 procedure SetListSource(Value: TDataSource); 148 procedure SetLookupCache(const Value: boolean); 149 function HandleNullKey(var Key: Word; Shift: TShiftState): Boolean; 150 protected 151 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 152 public 153 constructor Create(AOwner: TComponent); override; 154 destructor Destroy; override; 155 procedure Initialize(AControlDataLink: TFieldDataLink; AControlItems: TStrings); 156 function KeyFieldValue: Variant; 157 procedure UpdateData(ValueIndex: Integer; ScrollDataset: Boolean); 158 function GetKeyValue(ValueIndex: Integer): Variant; 159 function GetKeyIndex: Integer; 160 function GetKeyIndex(const AKeyValue: Variant): Integer; 161 property ControlItems: TStrings read FControlItems write FControlItems; 162 property LookupCache: boolean read FLookupCache write SetLookupCache; 163 // properties to be published by owner control 164 // these are not used where data control Field is dbLookup 165 property KeyField: string read GetKeyFieldName write SetKeyFieldName; 166 property ListField: string read FListFieldName write SetListFieldName; 167 property ListFieldIndex: Integer read FListFieldIndex write FListFieldIndex default 0; 168 property ListSource: TDataSource read GetListSource write SetListSource; 169 property NullValueKey: TShortcut read FNullValueKey write FNullValueKey; 170 end; 171 172 { TDBEdit } 173 174 TDBEdit = class(TCustomMaskEdit) 175 private 176 FDataLink: TFieldDataLink; 177 FCustomEditMask: Boolean; 178 FFocusedDisplay: boolean; 179 procedure DataChange(Sender: TObject); 180 procedure UpdateData(Sender: TObject); 181 function GetDataField: string; 182 function GetDataSource: TDataSource; 183 function GetField: TField; 184 procedure SetDataField(const Value: string); 185 procedure SetDataSource(Value: TDataSource); 186 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 187 protected 188 function GetReadOnly: Boolean; override; 189 procedure SetReadOnly(Value: Boolean); override; 190 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 191 procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override; 192 193 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 194 195 function EditCanModify: Boolean; override; 196 function GetEditText: string; override; 197 198 procedure Change; override; 199 procedure Reset; override; 200 201 procedure WMSetFocus(var Message: TLMSetFocus); message LM_SETFOCUS; 202 procedure WMKillFocus(var Message: TLMKillFocus); message LM_KILLFOCUS; 203 procedure WndProc(var Message: TLMessage); override; 204 public 205 constructor Create(AOwner: TComponent); override; 206 destructor Destroy; override; 207 function ExecuteAction(AAction: TBasicAction): Boolean; override; 208 function UpdateAction(AAction: TBasicAction): Boolean; override; 209 property Field: TField read GetField; 210 published 211 property CustomEditMask: Boolean read FCustomEditMask write FCustomEditMask default False; 212 property DataField: string read GetDataField write SetDataField; 213 property DataSource: TDataSource read GetDataSource write SetDataSource; 214 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 215 216 property Align; 217 property Alignment; 218 property Anchors; 219 property AutoSelect; 220 property AutoSize; 221 property BiDiMode; 222 property BorderSpacing; 223 property BorderStyle; 224 property CharCase; 225 property Color; 226 property Constraints; 227 property DoubleBuffered; 228 property DragCursor; 229 property DragKind; 230 property DragMode; 231 property Enabled; 232 property EditMask; 233 property Font; 234 property MaxLength; 235 property ParentBiDiMode; 236 property ParentColor; 237 property ParentDoubleBuffered; 238 property ParentFont; 239 property ParentShowHint; 240 property PasswordChar; 241 property PopupMenu; 242 property ShowHint; 243 property TabOrder; 244 property TabStop; 245 property Visible; 246 property OnChange; 247 property OnClick; 248 property OnContextPopup; 249 property OnDblClick; 250 property OnDragDrop; 251 property OnDragOver; 252 property OnEditingDone; 253 property OnEndDrag; 254 property OnEnter; 255 property OnExit; 256 property OnKeyDown; 257 property OnKeyPress; 258 property OnKeyUp; 259 property OnMouseDown; 260 property OnMouseEnter; 261 property OnMouseLeave; 262 property OnMouseMove; 263 property OnMouseUp; 264 property OnMouseWheel; 265 property OnMouseWheelDown; 266 property OnMouseWheelUp; 267 property OnStartDrag; 268 property OnUTF8KeyPress; 269 end; 270 271 272 { TDBText } 273 274 TDBText = class(TCustomLabel) 275 private 276 FDataLink: TFieldDataLink; 277 278 procedure DataChange(Sender: TObject); 279 function GetDataField: string; 280 function GetDataSource: TDataSource; 281 function GetField: TField; 282 283 procedure SetDataField(const Value: string); 284 procedure SetDataSource(Value: TDataSource); 285 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 286 protected 287 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 288 class procedure WSRegisterClass; override; 289 procedure Loaded; override; 290 public 291 constructor Create(AOwner: TComponent); override; 292 destructor Destroy; override; 293 function ExecuteAction(AAction: TBasicAction): Boolean; override; 294 function UpdateAction(AAction: TBasicAction): Boolean; override; 295 property Field: TField read GetField; 296 published 297 property Align; 298 property Alignment; 299 property Anchors; 300 property AutoSize; 301 property BidiMode; 302 property BorderSpacing; 303 property Color; 304 property Constraints; 305 property DataField: string read GetDataField write SetDataField; 306 property DataSource: TDataSource read GetDataSource write SetDataSource; 307 property DragCursor; 308 property DragKind; 309 property DragMode; 310 property Enabled; 311 property FocusControl; 312 property Font; 313 property Layout; 314 property ParentBidiMode; 315 property ParentColor; 316 property ParentFont; 317 property ParentShowHint; 318 property PopupMenu; 319 property ShowAccelChar; 320 property ShowHint; 321 property Transparent; 322 property Visible; 323 property WordWrap; 324 property OnClick; 325 property OnDblClick; 326 property OnDragDrop; 327 property OnDragOver; 328 property OnEndDrag; 329 property OnMouseDown; 330 property OnMouseEnter; 331 property OnMouseLeave; 332 property OnMouseMove; 333 property OnMouseUp; 334 property OnMouseWheel; 335 property OnMouseWheelDown; 336 property OnMouseWheelUp; 337 property OnChangeBounds; 338 property OnContextPopup; 339 property OnResize; 340 property OnStartDrag; 341 property OptimalFill; 342 end; 343 344 { TCustomDBListBox } 345 346 TCustomDBListBox = class(TCustomListBox) 347 private 348 function GetDataField: string; 349 function GetDataSource: TDataSource; 350 function GetField: TField; 351 352 function GetReadOnly: Boolean; 353 procedure SetReadOnly(Value: Boolean); 354 355 procedure SetDataField(const Value: string); 356 procedure SetDataSource(Value: TDataSource); 357 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 358 protected 359 FDataLink: TFieldDataLink; 360 procedure DataChange(Sender: TObject); virtual; abstract; 361 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 362 363 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 364 procedure UpdateData(Sender: TObject); virtual; abstract; 365 // we need to override the Items Write method for db aware. 366 procedure SetItems(Values : TStrings); override; 367 public 368 constructor Create(AOwner: TComponent); override; 369 destructor Destroy; override; 370 function ExecuteAction(AAction: TBasicAction): Boolean; override; 371 function UpdateAction(AAction: TBasicAction): Boolean; override; 372 property Field: TField read GetField; 373 property DataField: string read GetDataField write SetDataField; 374 property DataSource: TDataSource read GetDataSource write SetDataSource; 375 376 //same as dbedit need to match the datalink status 377 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 378 end; 379 380 { TDBListBox } 381 382 TDBListBox = class(TCustomDBListBox) 383 protected 384 procedure DataChange(Sender: TObject); override; 385 procedure DoSelectionChange(User: Boolean); override; 386 procedure UpdateData(Sender: TObject); override; 387 public 388 procedure EditingDone; override; 389 published 390 property Align; 391 property Anchors; 392 property BiDiMode; 393 property BorderSpacing; 394 property BorderStyle; 395 property Color; 396 property Constraints; 397 property DataField; 398 property DataSource; 399 property DoubleBuffered; 400 property DragCursor; 401 property DragKind; 402 property DragMode; 403 property Enabled; 404 property ExtendedSelect; 405 property Font; 406 property ItemHeight; 407 property Items; 408 property MultiSelect; 409 property OnClick; 410 property OnContextPopup; 411 property OnDblClick; 412 property OnDragDrop; 413 property OnDragOver; 414 property OnDrawItem; 415 property OnEndDrag; 416 property OnEnter; 417 property OnExit; 418 property OnKeyPress; 419 property OnKeyDown; 420 property OnKeyUp; 421 property OnMouseDown; 422 property OnMouseEnter; 423 property OnMouseLeave; 424 property OnMouseMove; 425 property OnMouseUp; 426 property OnMouseWheel; 427 property OnMouseWheelDown; 428 property OnMouseWheelUp; 429 property OnResize; 430 property OnStartDrag; 431 property OnUTF8KeyPress; 432 property Options; 433 property ParentBiDiMode; 434 property ParentDoubleBuffered; 435 property ParentShowHint; 436 property PopupMenu; 437 property ReadOnly; 438 property ShowHint; 439 property Sorted; 440 property Style; 441 property TabOrder; 442 property TabStop; 443 property TopIndex; 444 property Visible; 445 end; 446 447 448 { TDBLookupListBox } 449 450 TDBLookupListBox = class(TCustomDBListBox) 451 private 452 FLookup: TDBLookup; 453 FScrollListDataset: Boolean; 454 procedure ActiveChange(Sender: TObject); 455 function GetKeyField: string; 456 function GetKeyValue: Variant; 457 function GetListField: string; 458 function GetListFieldIndex: Integer; 459 function GetListSource: TDataSource; 460 function GetLookupCache: boolean; 461 function GetNullValueKey: TShortCut; 462 procedure SetKeyField(const Value: string); 463 procedure SetKeyValue(const AValue: Variant); 464 procedure SetListField(const Value: string); 465 procedure SetListFieldIndex(const Value: Integer); 466 procedure SetListSource(const Value: TDataSource); 467 procedure SetLookupCache(const Value: boolean); 468 procedure SetNullValueKey(const AValue: TShortCut); 469 procedure UpdateLookup; 470 protected 471 procedure DataChange(Sender: TObject); override; 472 procedure DoSelectionChange(User: Boolean); override; 473 procedure InitializeWnd; override; 474 procedure DestroyWnd; override; 475 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 476 procedure Loaded; override; 477 procedure UpdateData(Sender: TObject); override; 478 function IsUnbound: boolean; 479 public 480 constructor Create(AOwner: TComponent); override; 481 property KeyValue: Variant read GetKeyValue write SetKeyValue; 482 published 483 property Align; 484 property Anchors; 485 property BiDiMode; 486 property BorderSpacing; 487 property BorderStyle; 488 property Color; 489 property Constraints; 490 property DataField; 491 property DataSource; 492 property DoubleBuffered; 493 property DragCursor; 494 property DragKind; 495 property DragMode; 496// property ExtendedSelect; 497// property ItemHeight; 498 property Enabled; 499 property Font; 500 property KeyField: string read GetKeyField write SetKeyField; 501 property ListField: string read GetListField write SetListField; 502 property ListFieldIndex: Integer read GetListFieldIndex write SetListFieldIndex; 503 property ListSource: TDataSource read GetListSource write SetListSource; 504 property LookupCache: boolean read GetLookupCache write SetLookupCache; 505 property NullValueKey: TShortCut read GetNullValueKey write SetNullValueKey default 0; 506// property MultiSelect; 507 property OnClick; 508 property OnContextPopup; 509 property OnDblClick; 510 property OnDragDrop; 511 property OnDragOver; 512// property OnDrawItem; 513 property OnEditingDone; 514 property OnEndDrag; 515 property OnEnter; 516 property OnExit; 517 property OnKeyPress; 518 property OnKeyDown; 519 property OnKeyUp; 520 property OnMouseDown; 521 property OnMouseEnter; 522 property OnMouseLeave; 523 property OnMouseMove; 524 property OnMouseUp; 525 property OnMouseWheel; 526 property OnMouseWheelDown; 527 property OnMouseWheelUp; 528 property OnResize; 529 property OnStartDrag; 530 property OnUTF8KeyPress; 531 property Options; 532 property ParentBiDiMode; 533 property ParentDoubleBuffered; 534 property ParentShowHint; 535 property PopupMenu; 536 property ReadOnly; 537 property ScrollListDataset: Boolean read FScrollListDataset write FScrollListDataset default False; 538 property ShowHint; 539 property Sorted; 540// property Style; 541 property TabOrder; 542 property TabStop; 543 property TopIndex; 544 property Visible; 545 end; 546 547 548 { TDBRadioGroup } 549 550 TDBRadioGroup = class(TCustomRadioGroup) 551 private 552 FDataLink: TFieldDataLink; 553 FOnChange: TNotifyEvent; 554 FValue: string; 555 FValues: TStrings; 556 FInSetValue: boolean; 557 function GetDataField: string; 558 function GetDataSource: TDataSource; 559 function GetField: TField; 560 function GetReadOnly: Boolean; 561 procedure SetDataField(const AValue: string); 562 procedure SetDataSource(const AValue: TDataSource); 563 procedure SetItems(const AValue: TStrings); 564 procedure SetReadOnly(const AValue: Boolean); 565 procedure SetValue(const AValue: string); 566 procedure SetValues(const AValue: TStrings); 567 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 568 protected 569 procedure Change; virtual; 570 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 571 procedure DataChange(Sender: TObject); 572 procedure UpdateData(Sender: TObject); 573 property DataLink: TFieldDataLink read FDataLink; 574 function GetButtonValue(Index: Integer): string; 575 procedure UpdateRadioButtonStates; override; 576 public 577 constructor Create(TheOwner: TComponent); override; 578 destructor Destroy; override; 579 procedure EditingDone; override; 580 function ExecuteAction(AAction: TBasicAction): Boolean; override; 581 function UpdateAction(AAction: TBasicAction): Boolean; override; 582 property Field: TField read GetField; 583 property ItemIndex; 584 property Value: string read FValue write SetValue; 585 published 586 property Align; 587 property Anchors; 588 property AutoFill; 589 property AutoSize; 590 property BiDiMode; 591 property BorderSpacing; 592 property Caption; 593 property ChildSizing; 594 property Color; 595 property ColumnLayout; 596 property Columns; 597 property Constraints; 598 property DataField: string read GetDataField write SetDataField; 599 property DataSource: TDataSource read GetDataSource write SetDataSource; 600 property DoubleBuffered; 601 property DragCursor; 602 property DragMode; 603 property Enabled; 604 property Font; 605 property Items write SetItems; 606 property OnChange: TNotifyEvent read FOnChange write FOnChange; 607 property OnChangeBounds; 608 property OnClick; 609 property OnContextPopup; 610 property OnDragDrop; 611 property OnDragOver; 612 property OnEndDrag; 613 property OnMouseDown; 614 property OnMouseEnter; 615 property OnMouseLeave; 616 property OnMouseMove; 617 property OnMouseUp; 618 property OnMouseWheel; 619 property OnMouseWheelDown; 620 property OnMouseWheelUp; 621 property OnResize; 622 property OnStartDrag; 623 property ParentBiDiMode; 624 property ParentColor; 625 property ParentDoubleBuffered; 626 property ParentFont; 627 property ParentShowHint; 628 property PopupMenu; 629 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 630 property ShowHint; 631 property TabOrder; 632 property TabStop; 633 property Values: TStrings read FValues write SetValues; 634 property Visible; 635 end; 636 637 638 { TDBCheckBox } 639 640 TDBCheckBox = class(TCustomCheckBox) 641 private 642 FDataLink: TFieldDataLink; 643 FValueChecked: string; 644 FValueUnchecked: string; 645 function GetDataField: string; 646 function GetDataSource: TDataSource; 647 function GetField: TField; 648 function GetReadOnly: Boolean; 649 procedure SetDataField(const AValue: string); 650 procedure SetDataSource(const AValue: TDataSource); 651 procedure SetReadOnly(const AValue: Boolean); 652 procedure SetValueChecked(const AValue: string); 653 procedure SetValueUnchecked(const AValue: string); 654 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 655 protected 656 function GetFieldCheckState: TCheckBoxState; virtual; 657 procedure DataChange(Sender: TObject); 658 procedure DoOnChange; override; 659 procedure UpdateData(Sender: TObject); 660 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 661 public 662 constructor Create(TheOwner: TComponent); override; 663 destructor Destroy; override; 664 function ExecuteAction(AAction: TBasicAction): Boolean; override; 665 function UpdateAction(AAction: TBasicAction): Boolean; override; 666 property Checked; 667 property Field: TField read GetField; 668 property State; 669 published 670 property Action; 671 property Align; 672 property Alignment; 673 property AllowGrayed; 674 property Anchors; 675 property AutoSize; 676 property BiDiMode; 677 property BorderSpacing; 678 property Caption; 679 property Color; 680 property DataField: string read GetDataField write SetDataField; 681 property DataSource: TDataSource read GetDataSource write SetDataSource; 682 property DoubleBuffered; 683 property DragCursor; 684 property DragKind; 685 property DragMode; 686 property Enabled; 687 property Font; 688 property Hint; 689 property OnChange; 690 property OnClick; 691 property OnContextPopup; 692 property OnDragDrop; 693 property OnDragOver; 694 property OnEndDrag; 695 property OnEnter; 696 property OnExit; 697 property OnMouseDown; 698 property OnMouseEnter; 699 property OnMouseLeave; 700 property OnMouseMove; 701 property OnMouseUp; 702 property OnMouseWheel; 703 property OnMouseWheelDown; 704 property OnMouseWheelUp; 705 property OnStartDrag; 706 property ParentBiDiMode; 707 property ParentColor; 708 property ParentDoubleBuffered; 709 property ParentFont; 710 property ParentShowHint; 711 property PopupMenu; 712 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 713 property ShowHint; 714 property TabOrder; 715 property TabStop; 716 property ValueChecked: string read FValueChecked write SetValueChecked; 717 property ValueUnchecked: string read FValueUnchecked write SetValueUnchecked; 718 property Visible; 719 end; 720 721 722 { TCustomDBComboBox } 723 724 TCustomDBComboBox = class(TCustomComboBox) 725 private 726 FDataLink: TFieldDataLink; 727 FDetectedEvents: Word; 728 function GetDataField: string; 729 function GetDataSource: TDataSource; 730 function GetField: TField; 731 function GetReadOnly: Boolean; 732 procedure SetDataField(const AValue: string); 733 procedure SetDataSource(const AValue: TDataSource); 734 procedure SetReadOnly(const AValue: Boolean); 735 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 736 protected 737 function DoEdit: boolean; virtual; 738 procedure DoOnCloseUp; virtual; 739 procedure DoOnSelect; virtual; 740 procedure LMDeferredEdit(var Message: TLMessage); message LM_DEFERREDEDIT; 741 property DetectedEvents: Word read FDetectedEvents; 742 protected 743 procedure CloseUp; override; 744 Procedure Select; override; 745 procedure DataChange(Sender: TObject); virtual; abstract; 746 function DoMouseWheel(Shift: TShiftState; WheelDelta: Integer; MousePos: TPoint): Boolean; override; 747 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 748 procedure Change; override; 749 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 750 procedure UpdateData(Sender: TObject); virtual; abstract; 751 procedure UpdateRecord; 752 procedure WndProc(var Message: TLMessage); override; 753 public 754 constructor Create(TheOwner: TComponent); override; 755 destructor Destroy; override; 756 function ExecuteAction(AAction: TBasicAction): Boolean; override; 757 function UpdateAction(AAction: TBasicAction): Boolean; override; 758 procedure EditingDone; override; 759 property Field: TField read GetField; 760 property Text; 761 property ItemIndex; 762 property DataField: string read GetDataField write SetDataField; 763 property DataSource: TDataSource read GetDataSource write SetDataSource; 764 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 765 end; 766 767 768 { TDBComboBox } 769 770 TDBComboBox = class(TCustomDBComboBox) 771 protected 772 procedure DataChange(Sender: TObject); override; 773 procedure KeyPress(var Key: char); override; 774 procedure UpdateData(Sender: TObject); override; 775 published 776 property Align; 777 property Anchors; 778 property ArrowKeysTraverseList; 779 property AutoComplete; 780 property AutoCompleteText; 781 property AutoDropDown; 782 property AutoSelect; 783 property AutoSize; 784 property BiDiMode; 785 property BorderSpacing; 786 property BorderStyle; 787 property CharCase; 788 property Color; 789 property DataField; 790 property DataSource; 791 property DoubleBuffered; 792 property DragCursor; 793 property DragKind; 794 property DragMode; 795 property DropDownCount; 796 property Enabled; 797 property Font; 798 property ItemHeight; 799 property Items; 800 property ItemWidth; 801 property MaxLength default -1; 802 property OnChange; 803 property OnChangeBounds; 804 property OnClick; 805 property OnCloseUp; 806 property OnContextPopup; 807 property OnDblClick; 808 property OnDragDrop; 809 property OnDragOver; 810 property OnDrawItem; 811 property OnDropDown; 812 property OnEditingDone; 813 property OnEndDrag; 814 property OnEnter; 815 property OnExit; 816 property OnKeyDown; 817 property OnKeyPress; 818 property OnKeyUp; 819 property OnMouseDown; 820 property OnMouseEnter; 821 property OnMouseLeave; 822 property OnMouseMove; 823 property OnMouseUp; 824 property OnMouseWheel; 825 property OnMouseWheelDown; 826 property OnMouseWheelUp; 827 property OnSelect; 828 property OnStartDrag; 829 property OnUTF8KeyPress; 830 property ParentBiDiMode; 831 property ParentColor; 832 property ParentDoubleBuffered; 833 property ParentFont; 834 property ParentShowHint; 835 property PopupMenu; 836 property ReadOnly; 837 property ShowHint; 838 property Sorted; 839 property Style; 840 property TabOrder; 841 property TabStop; 842 property Visible; 843 end; 844 845 846 { TDBLookupComboBox } 847 848 TDBLookupComboBox = class(TCustomDBComboBox) 849 protected 850 function DoEdit: boolean; override; 851 function IsUnbound: boolean; 852 private 853 FLookup: TDBLookup; 854 FScrollListDataset: Boolean; 855 procedure ActiveChange(Sender: TObject); 856 function GetKeyField: string; 857 function GetKeyValue: variant; 858 function GetListField: string; 859 function GetListFieldIndex: Integer; 860 function GetListSource: TDataSource; 861 function GetLookupCache: boolean; 862 function GetNullValueKey: TShortCut; 863 procedure SetKeyField(const Value: string); 864 procedure SetKeyValue(const AValue: variant); 865 procedure SetListField(const Value: string); 866 procedure SetListFieldIndex(const Value: Integer); 867 procedure SetListSource(const Value: TDataSource); 868 procedure SetLookupCache(const Value: boolean); 869 procedure SetNullValueKey(const AValue: TShortCut); 870 procedure UpdateLookup; 871 procedure UpdateItemIndex; 872 protected 873 procedure InitializeWnd; override; 874 procedure DestroyWnd; override; 875 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 876 procedure UTF8KeyPress(var UTF8Key: TUTF8Char); override; 877 procedure Loaded; override; 878 procedure UpdateData(Sender: TObject); override; 879 procedure DataChange(Sender: TObject); override; 880 procedure DoOnSelect; override; 881 public 882 constructor Create(AOwner: TComponent); override; 883 property KeyValue: variant read GetKeyValue write SetKeyValue; 884 published 885 property Align; 886 property Anchors; 887 property ArrowKeysTraverseList; 888 property AutoComplete; 889 //property AutoCompleteText; 890 property AutoDropDown; 891 property AutoSelect; 892 property AutoSize; 893 property BiDiMode; 894 property BorderSpacing; 895 property BorderStyle; 896 property CharCase; 897 property Color; 898 property Constraints; 899 property DataField; 900 property DataSource; 901 property DoubleBuffered; 902 property DragCursor; 903 property DragKind; 904 property DragMode; 905 property DropDownCount; 906 property Enabled; 907 property Font; 908// property ItemHeight; 909// property ItemWidth; 910 property KeyField: string read GetKeyField write SetKeyField; 911 property ListField: string read GetListField write SetListField; 912 property ListFieldIndex: Integer read GetListFieldIndex write SetListFieldIndex; 913 property ListSource: TDataSource read GetListSource write SetListSource; 914 property LookupCache: boolean read GetLookupCache write SetLookupCache; 915// property MaxLength default -1; 916 property NullValueKey: TShortCut read GetNullValueKey write SetNullValueKey default 0; 917 property OnChange; 918 property OnChangeBounds; 919 property OnClick; 920 property OnCloseUp; 921 property OnContextPopup; 922 property OnDblClick; 923 property OnDragDrop; 924 property OnDragOver; 925 property OnDrawItem; 926 property OnDropDown; 927 property OnEditingDone; 928 property OnEndDrag; 929 property OnEnter; 930 property OnExit; 931 property OnKeyDown; 932 property OnKeyPress; 933 property OnKeyUp; 934 property OnMouseDown; 935 property OnMouseEnter; 936 property OnMouseLeave; 937 property OnMouseMove; 938 property OnMouseUp; 939 property OnMouseWheel; 940 property OnMouseWheelDown; 941 property OnMouseWheelUp; 942 property OnSelect; 943 property OnStartDrag; 944 property OnUTF8KeyPress; 945 property ParentBiDiMode; 946 property ParentColor; 947 property ParentDoubleBuffered; 948 property ParentFont; 949 property ParentShowHint; 950 property PopupMenu; 951 property ReadOnly; 952 property ScrollListDataset: Boolean read FScrollListDataset write FScrollListDataset default False; 953 property ShowHint; 954 property Sorted; 955 property Style; 956 property TabOrder; 957 property TabStop; 958 property Visible; 959 end; 960 961 { TDBMemo } 962 963 TDBMemo = class(TCustomMemo) 964 private 965 FDataLink: TFieldDataLink; 966 FAutoDisplay: Boolean; 967 FDBMemoFocused: Boolean; 968 FDBMemoLoaded: Boolean; 969 function GetDataField: string; 970 function GetDataSource: TDataSource; 971 function GetField: TField; 972 procedure SetAutoDisplay(const AValue: Boolean); 973 procedure SetDataField(const AValue: string); 974 procedure SetDataSource(const AValue: TDataSource); 975 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 976 protected 977 function GetReadOnly: Boolean; override; 978 procedure SetReadOnly(AValue: Boolean); override; 979 procedure DataChange(Sender: TObject); 980 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 981 procedure UpdateData(Sender: TObject); 982 procedure Change; override; 983 procedure KeyDown(var Key: Word; Shift: TShiftState); override; 984 procedure KeyPress(var Key:Char); override; 985 procedure WndProc(var Message : TLMessage); override; 986 class procedure WSRegisterClass; override; 987 public 988 constructor Create(TheOwner: TComponent); override; 989 destructor Destroy; override; 990 procedure EditingDone; override; 991 procedure LoadMemo; virtual; 992 function ExecuteAction(AAction: TBasicAction): Boolean; override; 993 function UpdateAction(AAction: TBasicAction): Boolean; override; 994 property Field: TField read GetField; 995 published 996 property Align; 997 property Alignment; 998 property Anchors; 999 property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; 1000 property BiDiMode; 1001 property BorderSpacing; 1002 property BorderStyle; 1003 property CharCase; 1004 property Color; 1005 property Constraints; 1006 property DataField: string read GetDataField write SetDataField; 1007 property DataSource: TDataSource read GetDataSource write SetDataSource; 1008 property DoubleBuffered; 1009 property DragCursor; 1010 property DragKind; 1011 property DragMode; 1012 property Enabled; 1013 property Font; 1014 property MaxLength; 1015 property OnChange; 1016 property OnClick; 1017 property OnContextPopup; 1018 property OnDblClick; 1019 property OnDragDrop; 1020 property OnDragOver; 1021 property OnEditingDone; 1022 property OnEndDrag; 1023 property OnEnter; 1024 property OnExit; 1025 property OnKeyDown; 1026 property OnKeyPress; 1027 property OnKeyUp; 1028 property OnMouseDown; 1029 property OnMouseEnter; 1030 property OnMouseLeave; 1031 property OnMouseMove; 1032 property OnMouseUp; 1033 property OnMouseWheel; 1034 property OnMouseWheelDown; 1035 property OnMouseWheelUp; 1036 property OnResize; 1037 property OnStartDrag; 1038 property OnUTF8KeyPress; 1039 property ParentBiDiMode; 1040 property ParentDoubleBuffered; 1041 property ParentFont; 1042 property ParentShowHint; 1043 property PopupMenu; 1044 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 1045 property ScrollBars; 1046 property ShowHint; 1047 property TabOrder; 1048 property Tabstop; 1049 property Visible; 1050 property WantReturns; 1051 property WantTabs; 1052 property WordWrap; 1053 end; 1054 1055 1056 { TDBGroupBox } 1057 1058 TDBGroupBox = class(TCustomGroupBox) 1059 private 1060 FDataLink: TFieldDataLink; 1061 function GetDataField: string; 1062 function GetDataSource: TDataSource; 1063 function GetField: TField; 1064 procedure SetDataField(const AValue: string); 1065 procedure SetDataSource(const AValue: TDataSource); 1066 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 1067 protected 1068 procedure DataChange(Sender: TObject); 1069 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1070 public 1071 constructor Create(TheOwner: TComponent); override; 1072 destructor Destroy; override; 1073 function ExecuteAction(AAction: TBasicAction): Boolean; override; 1074 function UpdateAction(AAction: TBasicAction): Boolean; override; 1075 property Field: TField read GetField; 1076 published 1077 property Align; 1078 property Anchors; 1079 property BiDiMode; 1080 property BorderSpacing; 1081 property Caption; 1082 property ClientHeight; 1083 property ClientWidth; 1084 property Color; 1085 property Constraints; 1086 property Cursor; 1087 property DataField: string read GetDataField write SetDataField; 1088 property DataSource: TDataSource read GetDataSource write SetDataSource; 1089 property DoubleBuffered; 1090 property DragCursor; 1091 property DragKind; 1092 property DragMode; 1093 property Enabled; 1094 property Font; 1095 property OnClick; 1096 property OnContextPopup; 1097 property OnDblClick; 1098 property OnDragDrop; 1099 property OnDragOver; 1100 property OnEndDrag; 1101 property OnEnter; 1102 property OnExit; 1103 property OnKeyDown; 1104 property OnKeyPress; 1105 property OnKeyUp; 1106 property OnMouseDown; 1107 property OnMouseEnter; 1108 property OnMouseLeave; 1109 property OnMouseMove; 1110 property OnMouseUp; 1111 property OnMouseWheel; 1112 property OnMouseWheelDown; 1113 property OnMouseWheelUp; 1114 property OnResize; 1115 property OnStartDrag; 1116 property OnUTF8KeyPress; 1117 property ParentBiDiMode; 1118 property ParentColor; 1119 property ParentDoubleBuffered; 1120 property ParentFont; 1121 property ParentShowHint; 1122 property PopupMenu; 1123 property ShowHint; 1124 property TabOrder; 1125 property TabStop; 1126 property Visible; 1127 end; 1128 1129 1130 { TDBImage } 1131 1132 TOnDBImageRead = procedure(Sender: TObject; S: TStream; var GraphExt : string) of object; 1133 TOnDBImageWrite = procedure(Sender: TObject; S: TStream; GraphExt : string) of object; 1134 1135 TDBImage = class(TCustomImage) 1136 private 1137 FDataLink: TFieldDataLink; 1138 FAutoDisplay: Boolean; 1139 FOnDBImageRead: TOnDBImageRead; 1140 FOnDBImageWrite: TOnDBImageWrite; 1141 FQuickDraw: Boolean; 1142 FPictureLoaded: boolean; 1143 FUpdatingRecord: boolean; 1144 FWriteHeader: Boolean; 1145 function GetDataField: string; 1146 function GetDataSource: TDataSource; 1147 function GetField: TField; 1148 function GetReadOnly: Boolean; 1149 procedure SetAutoDisplay(const AValue: Boolean); 1150 procedure SetDataField(const AValue: string); 1151 procedure SetDataSource(const AValue: TDataSource); 1152 procedure SetReadOnly(const AValue: Boolean); 1153 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 1154 protected 1155 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1156 procedure DataChange(Sender: TObject); 1157 procedure UpdateData(Sender: TObject); virtual; 1158 procedure PictureChanged(Sender: TObject); override; 1159 class procedure WSRegisterClass; override; 1160 procedure DoCopyToClipboard; 1161 public 1162 constructor Create(TheOwner: TComponent); override; 1163 destructor Destroy; override; 1164 function ExecuteAction(AAction: TBasicAction): Boolean; override; 1165 function UpdateAction(AAction: TBasicAction): Boolean; override; 1166 property Field: TField read GetField; 1167 procedure Change; virtual; 1168 1169 procedure LoadPicture; virtual; 1170 procedure CopyToClipboard; 1171 procedure CutToClipboard; 1172 procedure PasteFromClipboard; 1173 property PictureLoaded : boolean read FPictureLoaded; 1174 published 1175 property Align; 1176 property Anchors; 1177 property AntialiasingMode; 1178 property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; 1179 property AutoSize; 1180 property BorderSpacing; 1181 property Center; 1182 property Constraints; 1183 property DataField: string read GetDataField write SetDataField; 1184 property DataSource: TDataSource read GetDataSource write SetDataSource; 1185 property DragCursor; 1186 property DragKind; 1187 property DragMode; 1188 property KeepOriginXWhenClipped; 1189 property KeepOriginYWhenClipped; 1190 property OnClick; 1191 property OnContextPopup; 1192 property OnDblClick; 1193 property OnDBImageRead: TOnDBImageRead read FOnDBImageRead write FOnDBImageRead; 1194 property OnDBImageWrite: TOnDBImageWrite read FOnDBImageWrite write FOnDBImageWrite; 1195 property PopupMenu; 1196 property OnDragDrop; 1197 property OnDragOver; 1198 property OnEndDrag; 1199 property OnMouseDown; 1200 property OnMouseEnter; 1201 property OnMouseLeave; 1202 property OnMouseMove; 1203 property OnMouseUp; 1204 property OnMouseWheel; 1205 property OnMouseWheelDown; 1206 property OnMouseWheelUp; 1207 property OnResize; 1208 property OnStartDrag; 1209 property ParentShowHint; 1210 property Proportional; 1211 property QuickDraw: Boolean read FQuickDraw write FQuickDraw default True; 1212 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 1213 property ShowHint; 1214 property Stretch; 1215 property StretchInEnabled; 1216 property StretchOutEnabled; 1217 property Transparent; 1218 property Visible; 1219 property WriteHeader: Boolean read FWriteHeader write FWriteHeader default True; 1220 end; 1221 1222 { TDBCalendar } 1223 1224 TDBCalendar = class(TCalendar) 1225 private 1226 FDataLink: TFieldDataLink; 1227 1228 procedure DataChange(Sender: TObject); 1229 procedure UpdateData(Sender: TObject); 1230 function GetDataField: string; 1231 function GetDataSource: TDataSource; 1232 function GetField: TField; 1233 1234 function GetReadOnly: Boolean; 1235 procedure SetReadOnly(Value: Boolean); 1236 1237 procedure SetDate(const AValue: String); 1238 1239 procedure SetDataField(const Value: string); 1240 procedure SetDataSource(Value: TDataSource); 1241 procedure UpdateDate(const AValue: string); 1242 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 1243 protected 1244 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1245 public 1246 constructor Create(TheOwner: TComponent); override; 1247 destructor Destroy; override; 1248 procedure EditingDone; override; 1249 function ExecuteAction(AAction: TBasicAction): Boolean; override; 1250 function UpdateAction(AAction: TBasicAction): Boolean; override; 1251 1252 property Field: TField read GetField; 1253 published 1254 property BorderSpacing; 1255 property DataField: string read GetDataField write SetDataField; 1256 property DataSource: TDataSource read GetDataSource write SetDataSource; 1257 1258 Property Date write SetDate stored False; 1259 property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; 1260 1261 property DisplaySettings stored False; 1262 property DoubleBuffered; 1263 property DragCursor; 1264 property DragMode; 1265 property ParentDoubleBuffered; 1266 property Visible; 1267 property OnClick; 1268 property OnContextPopup; 1269 property OnDragDrop; 1270 property OnDragOver; 1271 property OnEndDrag; 1272 property OnMouseMove; 1273 property OnMouseDown; 1274 property OnDayChanged; 1275 property OnMonthChanged; 1276 property OnStartDrag; 1277 property OnYearChanged; 1278 end; 1279 1280 1281 { TDBCustomNavigator } 1282 1283type 1284 TDBNavButton = class; 1285 TDBNavFocusableButton = class; 1286 TDBNavDataLink = class; 1287 1288 TDBNavGlyph = (ngEnabled, ngDisabled); 1289 TDBNavButtonType = (nbFirst, nbPrior, nbNext, nbLast, 1290 nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh); 1291 TDBNavButtonSet = set of TDBNavButtonType; 1292 TDBNavButtonStyle = set of (nsAllowTimer, nsFocusRect); 1293 TDBNavButtonDirection = (nbdHorizontal,nbdVertical); 1294 TDBNavigatorOption = (navFocusableButtons); 1295 TDBNavigatorOptions = set of TDBNavigatorOption; 1296 1297 // for Delphi compatibility 1298 TNavigateBtn = TDBNavButtonType; 1299 1300 TDBNavClickEvent = procedure(Sender: TObject; 1301 Button: TDBNavButtonType) of object; 1302 1303const 1304 DefaultDBNavigatorButtons = [nbFirst, nbPrior, nbNext, nbLast, 1305 nbInsert, nbDelete, nbEdit, nbPost, nbCancel, nbRefresh]; 1306 DBNavButtonResourceName: array[TDBNavButtonType] of string = ( 1307 { nbFirst } 'DBNavFirst', 1308 { nbPrior } 'DBNavPrior', 1309 { nbNext } 'DBNavNext', 1310 { nbLast } 'DBNavLast', 1311 { nbInsert } 'DBNavInsert', 1312 { nbDelete } 'DBNavDelete', 1313 { nbEdit } 'DBNavEdit', 1314 { nbPost } 'DBNavPost', 1315 { nbCancel } 'DBNavCancel', 1316 { nbRefresh } 'DBNavRefresh' 1317 ); 1318 1319type 1320 1321 { TDBCustomNavigator } 1322 1323 TDBCustomNavigator = class(TCustomPanel) 1324 private 1325 FBeforeAction: TDBNavClickEvent; 1326 FDataLink: TDBNavDataLink; 1327 FDirection: TDBNavButtonDirection; 1328 FOnNavClick: TDBNavClickEvent; 1329 FVisibleButtons: TDBNavButtonSet; 1330 FDefaultHints: TStrings; 1331 FHints: TStrings; 1332 FUpdateButtonsLock: integer; 1333 FOriginalHints: String; 1334 FOptions: TDBNavigatorOptions; 1335 FFlat: Boolean; 1336 FConfirmDelete: Boolean; 1337 FUpdateButtonsNeeded: boolean; 1338 FShowButtonHints: boolean; 1339 FImages: TCustomImageList; 1340 FImageChangeLink: TChangeLink; 1341 procedure DefaultHintsChanged(Sender: TObject); 1342 function GetDataSource: TDataSource; 1343 function GetHints: TStrings; 1344 procedure SetDataSource(const AValue: TDataSource); 1345 procedure SetDirection(const AValue: TDBNavButtonDirection); 1346 procedure SetFlat(const AValue: Boolean); 1347 procedure SetHints(const AValue: TStrings); 1348 procedure SetImages(AValue: TCustomImageList); 1349 procedure SetOptions(AValue: TDBNavigatorOptions); 1350 procedure SetShowButtonHints(const AValue: boolean); 1351 procedure SetVisibleButtons(const AValue: TDBNavButtonSet); 1352 procedure CMGetDataLink(var Message: TLMessage); message CM_GETDATALINK; 1353 procedure ImageListChange(Sender: TObject); 1354 protected 1355 Buttons: array[TDBNavButtonType] of TDBNavButton; 1356 FocusableButtons: array[TDBNavButtonType] of TDBNavFocusableButton; 1357 procedure DataChanged; virtual; 1358 procedure EditingChanged; virtual; 1359 procedure ActiveChanged; virtual; 1360 procedure Loaded; override; 1361 procedure Notification(AComponent: TComponent; Operation: TOperation); override; 1362 procedure UpdateButtons; virtual; 1363 procedure UpdateHints; virtual; 1364 procedure HintsChanged(Sender: TObject); virtual; 1365 procedure ButtonClickHandler(Sender: TObject); virtual; 1366 class function GetControlClassDefaultSize: TSize; override; 1367 procedure BeginUpdateButtons; virtual; 1368 procedure EndUpdateButtons; virtual; 1369 procedure SetEnabled(Value: Boolean); override; 1370 public 1371 constructor Create(TheOwner: TComponent); override; 1372 destructor Destroy; override; 1373 procedure BtnClick(Index: TNavigateBtn); virtual; 1374 function VisibleButtonCount: integer; virtual; 1375 public 1376 property BeforeAction: TDBNavClickEvent read FBeforeAction write FBeforeAction; 1377 property ConfirmDelete: Boolean read FConfirmDelete write FConfirmDelete default True; 1378 property DataSource: TDataSource read GetDataSource write SetDataSource; 1379 property Direction: TDBNavButtonDirection read FDirection write SetDirection default nbdHorizontal; 1380 property Flat: Boolean read FFlat write SetFlat default False; 1381 property Hints: TStrings read GetHints write SetHints; 1382 property Options: TDBNavigatorOptions read FOptions write SetOptions; 1383 property OnClick: TDBNavClickEvent read FOnNavClick write FOnNavClick; 1384 property VisibleButtons: TDBNavButtonSet read FVisibleButtons 1385 write SetVisibleButtons default DefaultDBNavigatorButtons; 1386 property ShowButtonHints: boolean read FShowButtonHints write SetShowButtonHints default true; 1387 property Images: TCustomImageList read FImages write SetImages; 1388 end; 1389 1390 1391 { TDBNavButton } 1392 1393 TDBNavButton = class(TSpeedButton) 1394 private 1395 FIndex: TDBNavButtonType; 1396 FNavStyle: TDBNavButtonStyle; 1397 protected 1398 public 1399 destructor Destroy; override; 1400 property NavStyle: TDBNavButtonStyle read FNavStyle write FNavStyle; 1401 property Index: TDBNavButtonType read FIndex write FIndex; 1402 end; 1403 1404 { TDBNavFocusableButton } 1405 1406 TDBNavFocusableButton = class(TBitBtn) 1407 private 1408 FIndex: TDBNavButtonType; 1409 FNavStyle: TDBNavButtonStyle; 1410 public 1411 property NavStyle: TDBNavButtonStyle read FNavStyle write FNavStyle; 1412 property Index: TDBNavButtonType read FIndex write FIndex; 1413 end; 1414 1415 { TNavDataLink } 1416 1417 TDBNavDataLink = class(TDataLink) 1418 private 1419 FNavigator: TDBCustomNavigator; 1420 protected 1421 procedure EditingChanged; override; 1422 procedure DataSetChanged; override; 1423 procedure ActiveChanged; override; 1424 public 1425 constructor Create(TheNavigator: TDBCustomNavigator); 1426 end; 1427 1428 1429 { TDBNavigator } 1430 1431 TDBNavigator = class(TDBCustomNavigator) 1432 published 1433 property Align default alNone; 1434 property Alignment; 1435 property Anchors; 1436 property AutoSize; 1437 property BidiMode; 1438 property BeforeAction; 1439 property BevelInner; 1440 property BevelOuter; 1441 property BevelWidth; 1442 property BorderSpacing; 1443 property BorderStyle; 1444 property BorderWidth; 1445 property Caption; 1446 property ChildSizing; 1447 property ClientHeight; 1448 property ClientWidth; 1449 property Color default clBackground; 1450 property ConfirmDelete; 1451 property DataSource; 1452 property Direction; 1453 property DoubleBuffered; 1454 property DragCursor; 1455 property DragMode; 1456 property Enabled; 1457 property Flat; 1458 property Font; 1459 property Hints; 1460 property OnClick; 1461 property OnContextPopup; 1462 property OnDblClick; 1463 property OnDragDrop; 1464 property OnDragOver; 1465 property OnEndDrag; 1466 property OnEnter; 1467 property OnExit; 1468 property OnMouseDown; 1469 property OnMouseEnter; 1470 property OnMouseLeave; 1471 property OnMouseMove; 1472 property OnMouseUp; 1473 property OnMouseWheel; 1474 property OnMouseWheelDown; 1475 property OnMouseWheelUp; 1476 property OnResize; 1477 property OnStartDrag; 1478 property Options; 1479 property ParentBidiMode; 1480 property ParentColor; 1481 property ParentDoubleBuffered; 1482 property ParentFont; 1483 property ParentShowHint; 1484 property PopupMenu; 1485 property ShowHint; 1486 property TabOrder; 1487 property TabStop default False; 1488 property Visible; 1489 property VisibleButtons; 1490 property Images; 1491 end; 1492 1493procedure ChangeDataSource(AControl: TControl; Link: TDataLink; 1494 NewDataSource: TDataSource); 1495 1496procedure Register; 1497 1498implementation 1499 1500{$R lcl_dbnav_images.res} 1501 1502uses 1503 InterfaceBase, Clipbrd; 1504 1505var 1506 FieldClasses: TFpList; 1507 1508procedure RegField(const FieldClass: TFieldClass); 1509begin 1510 if FieldClasses = nil then FieldClasses := TFpList.Create; 1511 if (FieldClass <> Nil) And (FieldClasses.IndexOf(FieldClass) = -1) then 1512 begin 1513 FieldClasses.Add(FieldClass); 1514 RegisterNoIcon([FieldClass]); 1515 RegisterClass(FieldClass); 1516 end; 1517end; 1518 1519procedure RegFields(const AFieldClasses: array of TFieldClass); 1520var I: Integer; 1521begin 1522 for I := Low(AFieldClasses) to High(AFieldClasses) do 1523 RegField(AFieldClasses[I]); 1524end; 1525 1526procedure ChangeDataSource(AControl: TControl; Link: TDataLink; 1527 NewDataSource: TDataSource); 1528begin 1529 if Link.DataSource=NewDataSource then exit; 1530 if Link.DataSource<>nil then 1531 Link.DataSource.RemoveFreeNotification(AControl); 1532 Link.DataSource:=NewDataSource; 1533 if Link.DataSource<>nil then 1534 Link.DataSource.FreeNotification(AControl); 1535end; 1536 1537function FieldIsEditable(Field: TField): boolean; 1538begin 1539 result := (Field<>nil) and (not Field.Calculated) and 1540 (Field.DataType<>ftAutoInc) and (Field.FieldKind<>fkLookup) 1541end; 1542 1543function FieldCanAcceptKey(Field: TField; AKey: char): boolean; 1544begin 1545 Result := FieldIsEditable(Field) and Field.IsValidChar(AKey); 1546end; 1547 1548procedure Register; 1549begin 1550 RegisterComponents('Data Controls',[TDBNavigator,TDBText,TDBEdit,TDBMemo, 1551 TDBImage,TDBListBox,TDBLookupListBox,TDBComboBox,TDBLookupComboBox, 1552 TDBCheckBox, TDBRadioGroup, TDBCalendar,TDBGroupBox]); 1553 RegFields(DefaultFieldClasses); 1554 RegField(TIntegerField); 1555end; 1556 1557function TFieldDataLink.FieldCanModify: boolean; 1558var 1559 FieldList: TList; 1560 i: Integer; 1561begin 1562 result := Assigned(FField); 1563 if not result then 1564 exit; 1565 1566 if FField.FieldKind=fkLookup then 1567 begin 1568 FieldList := TList.Create; 1569 try 1570 DataSet.GetFieldList(FieldList, FField.KeyFields); 1571 result := (FieldList.Count>0); 1572 i := 0; 1573 while result and (i<FieldList.Count) do 1574 begin 1575 result := TField(FieldList[i]).CanModify; 1576 inc(i); 1577 end; 1578 finally 1579 FieldList.Free; 1580 end; 1581 end else 1582 result := FField.CanModify; 1583end; 1584 1585function TFieldDataLink.IsKeyField(aField: TField): Boolean; 1586var 1587 KeyFieldName, KeyFields: String; 1588 StrPos: Integer; 1589begin 1590 KeyFields := FField.KeyFields; 1591 StrPos := 1; 1592 while StrPos <= Length(KeyFields) do 1593 begin 1594 KeyFieldName := ExtractFieldName(KeyFields, StrPos); 1595 if SameText(aField.FieldName, KeyFieldName) then 1596 begin 1597 Result := True; 1598 Exit; 1599 end; 1600 end; 1601 Result := False; 1602end; 1603 1604{TFieldDataLink Private Methods} 1605{ 1606 If the field exists and can be modified, then 1607 we CanModify as long as this hasn't been set 1608 ReadOnly somewhere else. Do we need any extra tests here? 1609} 1610function TFieldDataLink.GetCanModify: Boolean; 1611begin 1612 if FieldCanModify then 1613 Result := not ReadOnly 1614 else 1615 Result := False; 1616end; 1617 1618{ 1619 Set the FieldName and then notify the changes though EditingChanged and Reset 1620 Ensure FField is nil if something goes wrong or FieldName is empty 1621} 1622procedure TFieldDataLink.SetFieldName(const Value: string); 1623begin 1624 if FFieldName <> Value then 1625 begin 1626 FFieldName := Value; 1627 UpdateField; 1628 if Active then 1629 begin 1630 EditingChanged; 1631 Reset; 1632 end; 1633 end; 1634end; 1635 1636procedure TFieldDataLink.UpdateField; 1637begin 1638 if Active and (FFieldName <> '') then 1639 FField := DataSet.FieldByName(FFieldName) 1640 else 1641 FField := nil; 1642end; 1643 1644{ 1645 This function checks if FField is still associated with the dataset 1646 If not update the field 1647} 1648procedure TFieldDataLink.ValidateField; 1649begin 1650 if not (DataSet.FindField(FFieldName) = FField) then 1651 UpdateField; 1652end; 1653 1654procedure TFieldDataLink.ResetEditingSource; 1655begin 1656 FEditingSource := false; 1657 FEditingSourceSet := false; 1658end; 1659 1660{TFieldDataLink Protected Methods} 1661 1662{ Delphi Help -> 1663 Changes to the Active property trigger the ActiveChanged method. 1664 If an OnActiveChange event handler is assigned, ActiveChanged calls 1665 this event handler. If ActiveChanged is triggered by a transition into 1666 an active state, then before calling the event handler, ActiveChanged makes 1667 sure that the Field for this TFieldDataLink is still valid. 1668 <-- Delphi Help 1669 1670 Update the field instance. When not Active field will be set to nil 1671 Call OnActiveChange 1672} 1673procedure TFieldDataLink.ActiveChanged; 1674begin 1675 if FFieldName <> '' then 1676 begin 1677 UpdateField; 1678 EditingChanged; 1679 Reset; 1680 end; 1681 if Assigned(FOnActiveChange) then 1682 FOnActiveChange(Self); 1683end; 1684 1685{ Delphi Help -> 1686 Changing the field binding can change the validity of the CanModify 1687 property, since individual field components can disallow edits. If 1688 TFieldDataLink is in an editing state when the Field property is changed, 1689 EditingChanged checks the CanModify property. If CanModify is False, it 1690 changes back out of the editing state. 1691 1692 Note: This differs significantly from the inherited EditingChanged method 1693 of TDataLink. The functionality of the inherited method is replaced in 1694 TFieldDataLink by the OnEditingChange event handler. 1695 <-- Delphi Help 1696 1697 ok so another event... but this time we simply change modified state 1698 if Editing and not CanModify? or do we also change to match if 1699 if not Editing and CanModify? i.e If Editing <> CanModify?? Will assume 1700 the latter just in case. easy to change back if I am wrong. 1701 1702 Also based on this we replace parent routine, so do we need to keep track 1703 of Editing state ourself? I hope this is right. Anyone know for sure? 1704 1705 OK .. based on the Modified routine we need to turn off 1706 our IsModified routine when succesfull right? so for now just turn 1707 it off as per my example. 1708} 1709procedure TFieldDataLink.EditingChanged; 1710var 1711 RealEditState : Boolean; 1712begin 1713 RealEditState := (CanModify and Inherited Editing); 1714 1715 if (FEditing <> RealEditState) then 1716 begin 1717 FEditing := RealEditState; 1718 if not FEditing then 1719 begin 1720 IsModified := False; 1721 ResetEditingSource; 1722 end; 1723 if Assigned(FOnEditingChange) then 1724 FOnEditingChange(Self); 1725 end; 1726end; 1727 1728{ Delphi Help -> 1729 LayoutChanged is called after changes in the layout of one of the 1730 containers of the Control for this TFieldDataLink that might change the 1731 validity of its field binding. For example, if the Control is embedded 1732 within a TCustomDBGrid, and one of the columns is deleted, the Field 1733 property for the Control might become invalid. 1734 <-- Delphi Help 1735 1736 Ensure FField is valid and notify 1737} 1738procedure TFieldDataLink.LayoutChanged; 1739begin 1740 ValidateField; 1741 if FField <> nil then 1742 begin 1743 EditingChanged; 1744 RecordChanged(nil); 1745 end; 1746end; 1747 1748{ Delphi Help -> 1749 Applications can not call this protected method. It is triggered 1750 automatically when the contents of the current record change. 1751 RecordChanged calls the OnDataChange event handler if there is one. 1752 1753 TDataLink.RecordChanged: 1754 The Field parameter indicates which field of the current record has changed in value. 1755 If Field is nil (Delphi) or NULL (C++), any number of fields within the current record may have changed. 1756 <-- Delphi Help 1757 1758 Call Reset if AField = FField or aField = nil 1759} 1760procedure TFieldDataLink.RecordChanged(aField: TField); 1761begin 1762 if (aField = nil) or (aField = FField) or 1763 ((FField <> nil) and (FField.FieldKind = fkLookup) and IsKeyField(aField)) then 1764 Reset; 1765end; 1766 1767{ Delphi Help -> 1768 UpdateData overrides the default UpdateData method to call the 1769 OnUpdateData event handler where the data-aware control can write any 1770 pending edits to the record in the dataset. 1771 <-- Delphi Help 1772 1773 where..can write pending events. So I guess when we have already 1774 called Modified? Aka if not IsModified exit otherwise call event? 1775 works for me. 1776} 1777procedure TFieldDataLink.UpdateData; 1778begin 1779 if not IsModified then 1780 exit; 1781 try 1782 if Assigned(FOnUpdateData) then 1783 FOnUpdateData(Self); 1784 finally 1785 IsModified := False; 1786 end; 1787end; 1788 1789{ Delphi Help -> 1790 Call FocusControl to give the Control associated with this TFieldDataLink 1791 object the input focus. FocusControl checks whether the Control can receive 1792 input focus, and if so, calls its SetFocus method to move focus to the 1793 Control. 1794 <-- Delphi Help 1795 1796 Check if the field matches and if Control is TWinControl than call SetFocus 1797 Set the FieldRef to nil so no other control get focus 1798} 1799 1800procedure TFieldDataLink.FocusControl(aField: TFieldRef); 1801var 1802 WinControl: TWinControl; 1803begin 1804 if Assigned(aField) and (aField^ = FField) and (FControl is TWinControl) then 1805 begin 1806 WinControl := TWinControl(FControl); 1807 if WinControl.CanFocus then 1808 begin 1809 aField^ := nil; 1810 WinControl.SetFocus; 1811 end; 1812 end; 1813end; 1814 1815{TFieldDataLink Public Methods} 1816 1817constructor TFieldDataLink.Create; 1818begin 1819 inherited Create; 1820 VisualControl := True; 1821 //FField := nil; 1822 //FFieldname := ''; 1823end; 1824 1825{ Delphi Help -> 1826 Use Edit to try to ensure that the contents of the field can be modified. 1827 A return value of True indicates that the field was already in an editing 1828 state, or that the DataSource was successfully changed to allow editing. 1829 A return value of False indicates that the DataSource could not be changed 1830 to allow editing. For example, if the CanModify property is False, Edit 1831 fails, and returns False. 1832 <-- Delphi Help 1833 1834 ok so the way I see it, since the inherited function calls EditingChanged, 1835 which we have already overriden to modify our own Editing state if its invalid, 1836 I should just be calling the inherited routine here, but only if CanModify, 1837 since there is no point otherwise. But since we _are_ keeping track of editing 1838 state ourselves we return our own state, not the inherited. If anyone know 1839 better please fix. 1840} 1841function TFieldDataLink.Edit: Boolean; 1842var 1843 editingSrc: Boolean; 1844begin 1845 editingSrc := (not FEditing) and (Dataset<>nil) and not(Dataset.State in dsEditModes); 1846 1847 if (not FEditing) and CanModify then 1848 inherited Edit; 1849 1850 Result := FEditing; 1851 1852 if not FEditingSourceSet then 1853 begin 1854 // should be triggered one time only if editing succeeded 1855 FEditingSource := FEditing and editingSrc; 1856 FEditingSourceSet := true; 1857 end; 1858end; 1859 1860{ Delphi Help -> 1861 Call Modified when the Control for this TFieldDataLink begins processing 1862 edits. 1863 <-- Delphi Help 1864 1865 ok so. well _that's_ helpfull. for the moment going to keep track 1866 by adding an IsModified... based on the other functions thus far 1867 we need to know whether we are in state, so I am assuming it goes 1868 1869 Call Modified -> 1870 IsModified:=True;//Waiting for modifications 1871 1872 Call SomeFunction-> 1873 If IsModified then begin 1874 (do something) 1875 IsModified := False;//All modifications complete 1876 end 1877 else 1878 (do something else? exit?); 1879} 1880procedure TFieldDataLink.Modified; 1881begin 1882 IsModified := True; 1883end; 1884 1885{ Delphi Help -> 1886 The Control that owns a TFieldDataLink object calls its Reset method to 1887 process a UI action that cancels edits to the field. Reset calls the 1888 OnDataChange event handler without writing any pending changes to the 1889 record in the dataset. 1890 <-- Delphi Help 1891 1892 Just call to the OnDataChange Event, and turn off IsModified 1893} 1894procedure TFieldDataLink.Reset; 1895begin 1896 if Assigned(FOnDataChange) then 1897 FOnDataChange(Self); 1898 1899 IsModified := False; 1900 ResetEditingSource; 1901end; 1902 1903CONST 1904 DBCBEVENT_CHANGE = 1; // CustomDBCombobox Detected change event 1905 DBCBEVENT_SELECT = 2; // CustomDBCombobox Detected select event 1906 DBCBEVENT_CLOSEUP = 4; // CustomDBCombobox Detected closeup event 1907 DBCBEVENT_WHEEL = 8; // CustomDBCombobox Detected mousewheel event 1908 1909{$Include dblookup.inc} 1910{$Include dbedit.inc} 1911{$Include dbtext.inc} 1912{$Include customdblistbox.inc} 1913{$Include dblistbox.inc} 1914{$Include dblookuplistbox.inc} 1915{$Include dbradiogroup.inc} 1916{$Include dbcheckbox.inc} 1917{$Include customdbcombobox.inc} 1918{$Include dbcombobox.inc} 1919{$Include dblookupcombobox.inc} 1920{$Include dbmemo.inc} 1921{$Include dbgroupbox.inc} 1922{$Include dbimage.inc} 1923{$Include dbcalendar.inc} 1924{$Include dbcustomnavigator.inc} 1925 1926 1927initialization 1928 RegisterPropertyToSkip(TField,'Calculated','VCL compatibility property', ''); 1929 1930finalization 1931 FieldClasses.Free; 1932 1933end. 1934