{*****************************************************************************} { } { Tnt Delphi Unicode Controls } { http://www.tntware.com/delphicontrols/unicode/ } { Version: 2.3.0 } { } { Copyright (c) 2002-2007, Troy Wolbrink (troy.wolbrink@tntware.com) } { } {*****************************************************************************} unit TntDBCtrls; {$INCLUDE TntCompilers.inc} interface uses Classes, Windows, Messages, DB, DBCtrls, Controls, StdCtrls, TntClasses, TntStdCtrls, TntControls, TntComCtrls, TntExtCtrls; type {TNT-WARN TPaintControl} TTntPaintControl = class private FOwner: TWinControl; FClassName: WideString; FHandle: HWnd; FObjectInstance: Pointer; FDefWindowProc: Pointer; FCtl3dButton: Boolean; function GetHandle: HWnd; procedure SetCtl3DButton(Value: Boolean); procedure WndProc(var Message: TMessage); public constructor Create(AOwner: TWinControl; const ClassName: WideString); destructor Destroy; override; procedure DestroyHandle; property Ctl3DButton: Boolean read FCtl3dButton write SetCtl3dButton; property Handle: HWnd read GetHandle; end; type {TNT-WARN TDBEdit} TTntDBEdit = class(TDBEdit{TNT-ALLOW TDBEdit}) private InheritedDataChange: TNotifyEvent; FPasswordChar: WideChar; procedure DataChange(Sender: TObject); procedure UpdateData(Sender: TObject); function GetHint: WideString; procedure SetHint(const Value: WideString); function IsHintStored: Boolean; procedure WMPaint(var Message: TWMPaint); message WM_PAINT; function GetTextMargins: TPoint; function GetPasswordChar: WideChar; procedure SetPasswordChar(const Value: WideChar); procedure CMEnter(var Message: TCMEnter); message CM_ENTER; private function GetSelStart: Integer; reintroduce; virtual; procedure SetSelStart(const Value: Integer); reintroduce; virtual; function GetSelLength: Integer; reintroduce; virtual; procedure SetSelLength(const Value: Integer); reintroduce; virtual; function GetSelText: WideString; reintroduce; procedure SetSelText(const Value: WideString); function GetText: WideString; procedure SetText(const Value: WideString); protected procedure CreateWindowHandle(const Params: TCreateParams); override; procedure CreateWnd; override; procedure DefineProperties(Filer: TFiler); override; function GetActionLinkClass: TControlActionLinkClass; override; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; public constructor Create(AOwner: TComponent); override; property SelText: WideString read GetSelText write SetSelText; property SelStart: Integer read GetSelStart write SetSelStart; property SelLength: Integer read GetSelLength write SetSelLength; property Text: WideString read GetText write SetText; published property Hint: WideString read GetHint write SetHint stored IsHintStored; property PasswordChar: WideChar read GetPasswordChar write SetPasswordChar default #0; end; {TNT-WARN TDBText} TTntDBText = class(TDBText{TNT-ALLOW TDBText}) private FDataLink: TFieldDataLink; InheritedDataChange: TNotifyEvent; function GetHint: WideString; procedure SetHint(const Value: WideString); function IsHintStored: Boolean; procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW; procedure CMDialogChar(var Message: TCMDialogChar); message CM_DIALOGCHAR; function GetCaption: TWideCaption; function IsCaptionStored: Boolean; procedure SetCaption(const Value: TWideCaption); function GetFieldText: WideString; procedure DataChange(Sender: TObject); protected procedure DefineProperties(Filer: TFiler); override; function GetLabelText: WideString; reintroduce; virtual; function GetActionLinkClass: TControlActionLinkClass; override; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; procedure DoDrawText(var Rect: TRect; Flags: Longint); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; published property Hint: WideString read GetHint write SetHint stored IsHintStored; end; {TNT-WARN TDBComboBox} TTntCustomDBComboBox = class(TDBComboBox{TNT-ALLOW TDBComboBox}, IWideCustomListControl) private FDataLink: TFieldDataLink; FFilter: WideString; FLastTime: Cardinal; procedure UpdateData(Sender: TObject); procedure EditingChange(Sender: TObject); procedure CMEnter(var Message: TCMEnter); message CM_ENTER; procedure SetReadOnly; function GetHint: WideString; procedure SetHint(const Value: WideString); function IsHintStored: Boolean; procedure WMChar(var Message: TWMChar); message WM_CHAR; private FItems: TTntStrings; FSaveItems: TTntStrings; FSaveItemIndex: integer; function GetItems: TTntStrings; procedure SetItems(const Value: TTntStrings); reintroduce; function GetSelStart: Integer; procedure SetSelStart(const Value: Integer); function GetSelLength: Integer; procedure SetSelLength(const Value: Integer); function GetSelText: WideString; procedure SetSelText(const Value: WideString); function GetText: WideString; procedure SetText(const Value: WideString); procedure CNCommand(var Message: TWMCommand); message CN_COMMAND; protected procedure DataChange(Sender: TObject); function GetAutoComplete_UniqueMatchOnly: Boolean; dynamic; function GetAutoComplete_PreserveDataEntryCase: Boolean; dynamic; procedure DoEditCharMsg(var Message: TWMChar); virtual; function GetFieldValue: Variant; virtual; procedure SetFieldValue(const Value: Variant); virtual; function GetComboValue: Variant; virtual; abstract; procedure SetComboValue(const Value: Variant); virtual; abstract; {$IFDEF DELPHI_7} // fix for Delphi 7 only function GetItemsClass: TCustomComboBoxStringsClass; override; {$ENDIF} protected procedure CreateWindowHandle(const Params: TCreateParams); override; procedure DefineProperties(Filer: TFiler); override; function GetActionLinkClass: TControlActionLinkClass; override; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; procedure CreateWnd; override; procedure DestroyWnd; override; procedure WndProc(var Message: TMessage); override; procedure ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); override; procedure KeyPress(var Key: AnsiChar); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; procedure CopySelection(Destination: TCustomListControl); override; procedure AddItem(const Item: WideString; AObject: TObject); reintroduce; virtual; public property SelText: WideString read GetSelText write SetSelText; property SelStart: Integer read GetSelStart write SetSelStart; property SelLength: Integer read GetSelLength write SetSelLength; property Text: WideString read GetText write SetText; published property Hint: WideString read GetHint write SetHint stored IsHintStored; property Items: TTntStrings read GetItems write SetItems; end; TTntDBComboBox = class(TTntCustomDBComboBox) protected function GetFieldValue: Variant; override; procedure SetFieldValue(const Value: Variant); override; function GetComboValue: Variant; override; procedure SetComboValue(const Value: Variant); override; end; type {TNT-WARN TDBCheckBox} TTntDBCheckBox = class(TDBCheckBox{TNT-ALLOW TDBCheckBox}) private function GetCaption: TWideCaption; procedure SetCaption(const Value: TWideCaption); function GetHint: WideString; procedure SetHint(const Value: WideString); function IsCaptionStored: Boolean; function IsHintStored: Boolean; protected procedure CreateWindowHandle(const Params: TCreateParams); override; procedure DefineProperties(Filer: TFiler); override; function GetActionLinkClass: TControlActionLinkClass; override; procedure ActionChange(Sender: TObject; CheckDefaults: Boolean); override; procedure Toggle; override; published property Caption: TWideCaption read GetCaption write SetCaption stored IsCaptionStored; property Hint: WideString read GetHint write SetHint stored IsHintStored; end; {TNT-WARN TDBRichEdit} TTntDBRichEdit = class(TTntCustomRichEdit) private FDataLink: TFieldDataLink; FAutoDisplay: Boolean; FFocused: Boolean; FMemoLoaded: Boolean; FDataSave: AnsiString; procedure BeginEditing; procedure DataChange(Sender: TObject); procedure EditingChange(Sender: TObject); function GetDataField: WideString; function GetDataSource: TDataSource; function GetField: TField; function GetReadOnly: Boolean; procedure SetDataField(const Value: WideString); procedure SetDataSource(Value: TDataSource); procedure SetReadOnly(Value: Boolean); procedure SetAutoDisplay(Value: Boolean); procedure SetFocused(Value: Boolean); procedure UpdateData(Sender: TObject); procedure WMCut(var Message: TMessage); message WM_CUT; procedure WMPaste(var Message: TMessage); message WM_PASTE; procedure CMEnter(var Message: TCMEnter); message CM_ENTER; procedure CMExit(var Message: TCMExit); message CM_EXIT; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; procedure CNNotify(var Message: TWMNotify); message CN_NOTIFY; protected procedure InternalLoadMemo; dynamic; procedure InternalSaveMemo; dynamic; protected procedure Change; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: AnsiChar); override; procedure Loaded; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ExecuteAction(Action: TBasicAction): Boolean; override; procedure LoadMemo; virtual; function UpdateAction(Action: TBasicAction): Boolean; override; function UseRightToLeftAlignment: Boolean; override; property Field: TField read GetField; published property Align; property Alignment; property Anchors; property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; property BevelEdges; property BevelInner; property BevelOuter; property BevelKind; property BevelWidth; property BiDiMode; property BorderStyle; property Color; property Constraints; property Ctl3D; property DataField: WideString read GetDataField write SetDataField; property DataSource: TDataSource read GetDataSource write SetDataSource; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property HideSelection; property HideScrollBars; property ImeMode; property ImeName; property MaxLength; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PlainText; property PopupMenu; property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; property ScrollBars; property ShowHint; property TabOrder; property TabStop; property Visible; property WantReturns; property WantTabs; property WordWrap; property OnChange; property OnClick; property OnContextPopup; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; {$IFDEF COMPILER_9_UP} property OnMouseActivate; {$ENDIF} property OnMouseDown; {$IFDEF COMPILER_10_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnMouseMove; property OnMouseUp; property OnResizeRequest; property OnSelectionChange; property OnProtectChange; property OnSaveClipboard; property OnStartDock; property OnStartDrag; end; type {TNT-WARN TDBMemo} TTntDBMemo = class(TTntCustomMemo) private FDataLink: TFieldDataLink; FAutoDisplay: Boolean; FFocused: Boolean; FMemoLoaded: Boolean; FPaintControl: TTntPaintControl; procedure DataChange(Sender: TObject); procedure EditingChange(Sender: TObject); function GetDataField: WideString; function GetDataSource: TDataSource; function GetField: TField; function GetReadOnly: Boolean; procedure SetDataField(const Value: WideString); procedure SetDataSource(Value: TDataSource); procedure SetReadOnly(Value: Boolean); procedure SetAutoDisplay(Value: Boolean); procedure SetFocused(Value: Boolean); procedure UpdateData(Sender: TObject); procedure WMCut(var Message: TMessage); message WM_CUT; procedure WMPaste(var Message: TMessage); message WM_PASTE; procedure WMUndo(var Message: TMessage); message WM_UNDO; procedure CMEnter(var Message: TCMEnter); message CM_ENTER; procedure CMExit(var Message: TCMExit); message CM_EXIT; procedure WMLButtonDblClk(var Message: TWMLButtonDblClk); message WM_LBUTTONDBLCLK; procedure WMPaint(var Message: TWMPaint); message WM_PAINT; procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; protected procedure Change; override; procedure KeyDown(var Key: Word; Shift: TShiftState); override; procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; procedure Loaded; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; procedure WndProc(var Message: TMessage); override; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ExecuteAction(Action: TBasicAction): Boolean; override; procedure LoadMemo; virtual; function UpdateAction(Action: TBasicAction): Boolean; override; function UseRightToLeftAlignment: Boolean; override; property Field: TField read GetField; published property Align; property Alignment; property Anchors; property AutoDisplay: Boolean read FAutoDisplay write SetAutoDisplay default True; property BevelEdges; property BevelInner; property BevelOuter; property BevelKind; property BevelWidth; property BiDiMode; property BorderStyle; property Color; property Constraints; property Ctl3D; property DataField: WideString read GetDataField write SetDataField; property DataSource: TDataSource read GetDataSource write SetDataSource; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property HideSelection; property ImeMode; property ImeName; property MaxLength; property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; property ScrollBars; property ShowHint; property TabOrder; property TabStop; property Visible; property WantReturns; property WantTabs; property WordWrap; property OnChange; property OnClick; property OnContextPopup; property OnDblClick; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; property OnKeyDown; property OnKeyPress; property OnKeyUp; {$IFDEF COMPILER_9_UP} property OnMouseActivate; {$ENDIF} property OnMouseDown; {$IFDEF COMPILER_10_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnMouseMove; property OnMouseUp; property OnStartDock; property OnStartDrag; end; { TDBRadioGroup } type TTntDBRadioGroup = class(TTntCustomRadioGroup) private FDataLink: TFieldDataLink; FValue: WideString; FValues: TTntStrings; FInSetValue: Boolean; FOnChange: TNotifyEvent; procedure DataChange(Sender: TObject); procedure UpdateData(Sender: TObject); function GetDataField: WideString; function GetDataSource: TDataSource; function GetField: TField; function GetReadOnly: Boolean; function GetButtonValue(Index: Integer): WideString; procedure SetDataField(const Value: WideString); procedure SetDataSource(Value: TDataSource); procedure SetReadOnly(Value: Boolean); procedure SetValue(const Value: WideString); procedure SetItems(Value: TTntStrings); procedure SetValues(Value: TTntStrings); procedure CMExit(var Message: TCMExit); message CM_EXIT; procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK; protected procedure Change; dynamic; procedure Click; override; procedure KeyPress(var Key: Char{TNT-ALLOW Char}); override; function CanModify: Boolean; override; procedure Notification(AComponent: TComponent; Operation: TOperation); override; property DataLink: TFieldDataLink read FDataLink; public constructor Create(AOwner: TComponent); override; destructor Destroy; override; function ExecuteAction(Action: TBasicAction): Boolean; override; function UpdateAction(Action: TBasicAction): Boolean; override; function UseRightToLeftAlignment: Boolean; override; property Field: TField read GetField; property ItemIndex; property Value: WideString read FValue write SetValue; published property Align; property Anchors; property BiDiMode; property Caption; property Color; property Columns; property Constraints; property Ctl3D; property DataField: WideString read GetDataField write SetDataField; property DataSource: TDataSource read GetDataSource write SetDataSource; property DragCursor; property DragKind; property DragMode; property Enabled; property Font; property Items write SetItems; {$IFDEF COMPILER_7_UP} property ParentBackground; {$ENDIF} property ParentBiDiMode; property ParentColor; property ParentCtl3D; property ParentFont; property ParentShowHint; property PopupMenu; property ReadOnly: Boolean read GetReadOnly write SetReadOnly default False; property ShowHint; property TabOrder; property TabStop; property Values: TTntStrings read FValues write SetValues; property Visible; property OnChange: TNotifyEvent read FOnChange write FOnChange; property OnClick; property OnContextPopup; property OnDragDrop; property OnDragOver; property OnEndDock; property OnEndDrag; property OnEnter; property OnExit; {$IFDEF COMPILER_10_UP} property OnMouseEnter; property OnMouseLeave; {$ENDIF} property OnStartDock; property OnStartDrag; end; implementation uses Forms, SysUtils, Graphics, Variants, TntDB, TntActnList, TntGraphics, TntSysUtils, RichEdit, Mask; function FieldIsBlobLike(Field: TField): Boolean; begin Result := False; if Assigned(Field) then begin if (Field.IsBlob) or (Field.DataType in [Low(TBlobType).. High(TBlobType)]) then Result := True else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) and (Field.Size = MaxInt) then Result := True; { wide string field filling in for a blob field } end; end; { TTntPaintControl } type TAccessWinControl = class(TWinControl); constructor TTntPaintControl.Create(AOwner: TWinControl; const ClassName: WideString); begin FOwner := AOwner; FClassName := ClassName; end; destructor TTntPaintControl.Destroy; begin DestroyHandle; end; procedure TTntPaintControl.DestroyHandle; begin if FHandle <> 0 then DestroyWindow(FHandle); Classes.FreeObjectInstance(FObjectInstance); FHandle := 0; FObjectInstance := nil; end; function TTntPaintControl.GetHandle: HWnd; var Params: TCreateParams; begin if FHandle = 0 then begin FObjectInstance := Classes.MakeObjectInstance(WndProc); TAccessWinControl(FOwner).CreateParams(Params); Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL); if (not Win32PlatformIsUnicode) then begin with Params do FHandle := CreateWindowEx(ExStyle, PAnsiChar(AnsiString(FClassName)), PAnsiChar(TAccessWinControl(FOwner).Text), Style or WS_VISIBLE, X, Y, Width, Height, Application.Handle, 0, HInstance, nil); FDefWindowProc := Pointer(GetWindowLong(FHandle, GWL_WNDPROC)); SetWindowLong(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); end else begin with Params do FHandle := CreateWindowExW(ExStyle, PWideChar(FClassName), PWideChar(TntControl_GetText(FOwner)), Style or WS_VISIBLE, X, Y, Width, Height, Application.Handle, 0, HInstance, nil); FDefWindowProc := Pointer(GetWindowLongW(FHandle, GWL_WNDPROC)); SetWindowLongW(FHandle, GWL_WNDPROC, Integer(FObjectInstance)); end; SendMessage(FHandle, WM_SETFONT, Integer(TAccessWinControl(FOwner).Font.Handle), 1); end; Result := FHandle; end; procedure TTntPaintControl.SetCtl3DButton(Value: Boolean); begin if FHandle <> 0 then DestroyHandle; FCtl3DButton := Value; end; procedure TTntPaintControl.WndProc(var Message: TMessage); begin with Message do if (Msg >= CN_CTLCOLORMSGBOX) and (Msg <= CN_CTLCOLORSTATIC) then Result := FOwner.Perform(Msg, WParam, LParam) else if (not Win32PlatformIsUnicode) then Result := CallWindowProcA(FDefWindowProc, FHandle, Msg, WParam, LParam) else Result := CallWindowProcW(FDefWindowProc, FHandle, Msg, WParam, LParam); end; { THackFieldDataLink } type THackFieldDataLink_D6_D7_D9 = class(TDataLink) protected FxxxField: TField; FxxxFieldName: string{TNT-ALLOW string}; FxxxControl: TComponent; FxxxEditing: Boolean; FModified: Boolean; end; {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 THackFieldDataLink = THackFieldDataLink_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 THackFieldDataLink = THackFieldDataLink_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 THackFieldDataLink = THackFieldDataLink_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 THackFieldDataLink = class(TDataLink) protected FxxxField: TField; FxxxFieldName: WideString; FxxxControl: TComponent; FxxxEditing: Boolean; FModified: Boolean; end; {$ENDIF} { TTntDBEdit } type THackDBEdit_D6_D7_D9 = class(TCustomMaskEdit) protected FDataLink: TFieldDataLink; FCanvas: TControlCanvas; FAlignment: TAlignment; FFocused: Boolean; end; {$IFDEF COMPILER_6} // verified against VCL source in Delphi 6 and BCB 6 THackDBEdit = THackDBEdit_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_7} // verified against VCL source in Delphi 7 THackDBEdit = THackDBEdit_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_9} // verified against VCL source in Delphi 9 THackDBEdit = THackDBEdit_D6_D7_D9; {$ENDIF} {$IFDEF DELPHI_10} // verified against VCL source in Delphi 10 THackDBEdit = THackDBEdit_D6_D7_D9; {$ENDIF} constructor TTntDBEdit.Create(AOwner: TComponent); begin inherited; InheritedDataChange := THackDBEdit(Self).FDataLink.OnDataChange; THackDBEdit(Self).FDataLink.OnDataChange := DataChange; THackDBEdit(Self).FDataLink.OnUpdateData := UpdateData; end; procedure TTntDBEdit.CreateWindowHandle(const Params: TCreateParams); begin CreateUnicodeHandle(Self, Params, 'EDIT'); end; procedure TTntDBEdit.CreateWnd; begin inherited; TntCustomEdit_AfterInherited_CreateWnd(Self, FPasswordChar); end; procedure TTntDBEdit.DefineProperties(Filer: TFiler); begin inherited; TntPersistent_AfterInherited_DefineProperties(Filer, Self); end; function TTntDBEdit.GetSelStart: Integer; begin Result := TntCustomEdit_GetSelStart(Self); end; procedure TTntDBEdit.SetSelStart(const Value: Integer); begin TntCustomEdit_SetSelStart(Self, Value); end; function TTntDBEdit.GetSelLength: Integer; begin Result := TntCustomEdit_GetSelLength(Self); end; procedure TTntDBEdit.SetSelLength(const Value: Integer); begin TntCustomEdit_SetSelLength(Self, Value); end; function TTntDBEdit.GetSelText: WideString; begin Result := TntCustomEdit_GetSelText(Self); end; procedure TTntDBEdit.SetSelText(const Value: WideString); begin TntCustomEdit_SetSelText(Self, Value); end; function TTntDBEdit.GetPasswordChar: WideChar; begin Result := TntCustomEdit_GetPasswordChar(Self, FPasswordChar) end; procedure TTntDBEdit.SetPasswordChar(const Value: WideChar); begin TntCustomEdit_SetPasswordChar(Self, FPasswordChar, Value); end; function TTntDBEdit.GetText: WideString; begin Result := TntControl_GetText(Self); end; procedure TTntDBEdit.SetText(const Value: WideString); begin TntControl_SetText(Self, Value); end; procedure TTntDBEdit.DataChange(Sender: TObject); begin with THackDBEdit(Self), Self do begin if Field = nil then InheritedDataChange(Sender) else begin if FAlignment <> Field.Alignment then begin EditText := ''; {forces update} FAlignment := Field.Alignment; end; EditMask := Field.EditMask; if not (csDesigning in ComponentState) then begin if (Field.DataType in [ftString, ftWideString]) and (MaxLength = 0) then MaxLength := Field.Size; end; if FFocused and FDataLink.CanModify then Text := GetWideText(Field) else begin Text := GetWideDisplayText(Field); if FDataLink.Editing and THackFieldDataLink(FDataLink).FModified then Modified := True; end; end; end; end; procedure TTntDBEdit.UpdateData(Sender: TObject); begin ValidateEdit; SetWideText(Field, Text); end; procedure TTntDBEdit.CMEnter(var Message: TCMEnter); var SaveFarEast: Boolean; begin SaveFarEast := SysLocale.FarEast; try SysLocale.FarEast := False; inherited; // inherited tries to work around Win95 FarEast bug, but introduces others finally SysLocale.FarEast := SaveFarEast; end; end; function TTntDBEdit.IsHintStored: Boolean; begin Result := TntControl_IsHintStored(Self); end; function TTntDBEdit.GetHint: WideString; begin Result := TntControl_GetHint(Self) end; procedure TTntDBEdit.SetHint(const Value: WideString); begin TntControl_SetHint(Self, Value); end; procedure TTntDBEdit.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); inherited; end; function TTntDBEdit.GetActionLinkClass: TControlActionLinkClass; begin Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); end; procedure TTntDBEdit.WMPaint(var Message: TWMPaint); const AlignStyle : array[Boolean, TAlignment] of DWORD = ((WS_EX_LEFT, WS_EX_RIGHT, WS_EX_LEFT), (WS_EX_RIGHT, WS_EX_LEFT, WS_EX_LEFT)); var ALeft: Integer; _Margins: TPoint; R: TRect; DC: HDC; PS: TPaintStruct; S: WideString; AAlignment: TAlignment; I: Integer; begin with THackDBEdit(Self), Self do begin AAlignment := FAlignment; if UseRightToLeftAlignment then ChangeBiDiModeAlignment(AAlignment); if ((AAlignment = taLeftJustify) or FFocused) and (not (csPaintCopy in ControlState)) or (not Win32PlatformIsUnicode) then begin inherited; Exit; end; { Since edit controls do not handle justification unless multi-line (and then only poorly) we will draw right and center justify manually unless the edit has the focus. } if FCanvas = nil then begin FCanvas := TControlCanvas.Create; FCanvas.Control := Self; end; DC := Message.DC; if DC = 0 then DC := BeginPaint(Handle, PS); FCanvas.Handle := DC; try FCanvas.Font := Font; with FCanvas do begin R := ClientRect; if not (NewStyleControls and Ctl3D) and (BorderStyle = bsSingle) then begin Brush.Color := clWindowFrame; FrameRect(R); InflateRect(R, -1, -1); end; Brush.Color := Color; if not Enabled then Font.Color := clGrayText; if (csPaintCopy in ControlState) and (Field <> nil) then begin S := GetWideDisplayText(Field); case CharCase of ecUpperCase: S := Tnt_WideUpperCase(S); ecLowerCase: S := Tnt_WideLowerCase(S); end; end else S := Text { EditText? }; if PasswordChar <> #0 then for I := 1 to Length(S) do S[I] := PasswordChar; _Margins := GetTextMargins; case AAlignment of taLeftJustify: ALeft := _Margins.X; taRightJustify: ALeft := ClientWidth - WideCanvasTextWidth(FCanvas, S) - _Margins.X - 1; else ALeft := (ClientWidth - WideCanvasTextWidth(FCanvas, S)) div 2; end; if SysLocale.MiddleEast then UpdateTextFlags; WideCanvasTextRect(FCanvas, R, ALeft, _Margins.Y, S); end; finally FCanvas.Handle := 0; if Message.DC = 0 then EndPaint(Handle, PS); end; end; end; function TTntDBEdit.GetTextMargins: TPoint; var DC: HDC; SaveFont: HFont; I: Integer; SysMetrics, Metrics: TTextMetric; begin if NewStyleControls then begin if BorderStyle = bsNone then I := 0 else if Ctl3D then I := 1 else I := 2; Result.X := SendMessage(Handle, EM_GETMARGINS, 0, 0) and $0000FFFF + I; Result.Y := I; end else begin if BorderStyle = bsNone then I := 0 else begin DC := GetDC(0); GetTextMetrics(DC, SysMetrics); SaveFont := SelectObject(DC, Font.Handle); GetTextMetrics(DC, Metrics); SelectObject(DC, SaveFont); ReleaseDC(0, DC); I := SysMetrics.tmHeight; if I > Metrics.tmHeight then I := Metrics.tmHeight; I := I div 4; end; Result.X := I; Result.Y := I; end; end; { TTntDBText } constructor TTntDBText.Create(AOwner: TComponent); begin inherited; FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; InheritedDataChange := FDataLink.OnDataChange; FDataLink.OnDataChange := DataChange; end; destructor TTntDBText.Destroy; begin FDataLink := nil; inherited; end; procedure TTntDBText.CMDialogChar(var Message: TCMDialogChar); begin TntLabel_CMDialogChar(Self, Message, Caption); end; function TTntDBText.IsCaptionStored: Boolean; begin Result := TntControl_IsCaptionStored(Self) end; function TTntDBText.GetCaption: TWideCaption; begin Result := TntControl_GetText(Self); end; procedure TTntDBText.SetCaption(const Value: TWideCaption); begin TntControl_SetText(Self, Value); end; procedure TTntDBText.DefineProperties(Filer: TFiler); begin inherited; TntPersistent_AfterInherited_DefineProperties(Filer, Self); end; function TTntDBText.GetLabelText: WideString; begin if csPaintCopy in ControlState then Result := GetFieldText else Result := Caption; end; procedure TTntDBText.DoDrawText(var Rect: TRect; Flags: Integer); begin if not TntLabel_DoDrawText(Self, Rect, Flags, GetLabelText) then inherited; end; function TTntDBText.IsHintStored: Boolean; begin Result := TntControl_IsHintStored(Self); end; function TTntDBText.GetHint: WideString; begin Result := TntControl_GetHint(Self) end; procedure TTntDBText.SetHint(const Value: WideString); begin TntControl_SetHint(Self, Value); end; procedure TTntDBText.CMHintShow(var Message: TMessage); begin ProcessCMHintShowMsg(Message); inherited; end; procedure TTntDBText.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); inherited; end; function TTntDBText.GetActionLinkClass: TControlActionLinkClass; begin Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); end; function TTntDBText.GetFieldText: WideString; begin if Field <> nil then Result := GetWideDisplayText(Field) else if csDesigning in ComponentState then Result := Name else Result := ''; end; procedure TTntDBText.DataChange(Sender: TObject); begin Caption := GetFieldText; end; { TTntCustomDBComboBox } constructor TTntCustomDBComboBox.Create(AOwner: TComponent); begin inherited; FItems := TTntComboBoxStrings.Create; TTntComboBoxStrings(FItems).ComboBox := Self; FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; FDataLink.OnDataChange := DataChange; FDataLink.OnUpdateData := UpdateData; FDataLink.OnEditingChange := EditingChange; end; destructor TTntCustomDBComboBox.Destroy; begin FreeAndNil(FItems); FreeAndNil(FSaveItems); FDataLink := nil; inherited; end; procedure TTntCustomDBComboBox.CreateWindowHandle(const Params: TCreateParams); begin CreateUnicodeHandle(Self, Params, 'COMBOBOX'); end; procedure TTntCustomDBComboBox.DefineProperties(Filer: TFiler); begin inherited; TntPersistent_AfterInherited_DefineProperties(Filer, Self); end; type TAccessCustomComboBox = class(TCustomComboBox{TNT-ALLOW TCustomComboBox}); procedure TTntCustomDBComboBox.CreateWnd; var PreInheritedAnsiText: AnsiString; begin PreInheritedAnsiText := TAccessCustomComboBox(Self).Text; inherited; TntCombo_AfterInherited_CreateWnd(Self, Items, FSaveItems, FSaveItemIndex, PreInheritedAnsiText); end; procedure TTntCustomDBComboBox.DestroyWnd; var SavedText: WideString; begin if not (csDestroyingHandle in ControlState) then begin { avoid recursion when parent is TToolBar and system font changes. } TntCombo_BeforeInherited_DestroyWnd(Self, Items, FSaveItems, ItemIndex, FSaveItemIndex, SavedText); inherited; TntControl_SetStoredText(Self, SavedText); end; end; procedure TTntCustomDBComboBox.SetReadOnly; begin if (Style in [csDropDown, csSimple]) and HandleAllocated then SendMessage(EditHandle, EM_SETREADONLY, Ord(not FDataLink.CanModify), 0); end; procedure TTntCustomDBComboBox.EditingChange(Sender: TObject); begin SetReadOnly; end; procedure TTntCustomDBComboBox.CMEnter(var Message: TCMEnter); var SaveFarEast: Boolean; begin SaveFarEast := SysLocale.FarEast; try SysLocale.FarEast := False; inherited; // inherited tries to work around Win95 FarEast bug, but introduces others finally SysLocale.FarEast := SaveFarEast; end; end; procedure TTntCustomDBComboBox.WndProc(var Message: TMessage); begin if (not (csDesigning in ComponentState)) and (Message.Msg = CB_SHOWDROPDOWN) and (Message.WParam = 0) and (not FDataLink.Editing) then begin DataChange(Self); {Restore text} Dispatch(Message); {Do NOT call inherited!} end else inherited WndProc(Message); end; procedure TTntCustomDBComboBox.ComboWndProc(var Message: TMessage; ComboWnd: HWnd; ComboProc: Pointer); begin if not TntCombo_ComboWndProc(Self, Message, ComboWnd, ComboProc, DoEditCharMsg) then inherited; end; procedure TTntCustomDBComboBox.KeyPress(var Key: AnsiChar); var SaveAutoComplete: Boolean; begin TntCombo_BeforeKeyPress(Self, SaveAutoComplete); try inherited; finally TntCombo_AfterKeyPress(Self, SaveAutoComplete); end; end; procedure TTntCustomDBComboBox.DoEditCharMsg(var Message: TWMChar); begin TntCombo_AutoCompleteKeyPress(Self, Items, Message, GetAutoComplete_UniqueMatchOnly, GetAutoComplete_PreserveDataEntryCase); end; procedure TTntCustomDBComboBox.WMChar(var Message: TWMChar); begin TntCombo_AutoSearchKeyPress(Self, Items, Message, FFilter, FLastTime); inherited; end; function TTntCustomDBComboBox.GetItems: TTntStrings; begin Result := FItems; end; procedure TTntCustomDBComboBox.SetItems(const Value: TTntStrings); begin FItems.Assign(Value); DataChange(Self); end; function TTntCustomDBComboBox.GetSelStart: Integer; begin Result := TntCombo_GetSelStart(Self); end; procedure TTntCustomDBComboBox.SetSelStart(const Value: Integer); begin TntCombo_SetSelStart(Self, Value); end; function TTntCustomDBComboBox.GetSelLength: Integer; begin Result := TntCombo_GetSelLength(Self); end; procedure TTntCustomDBComboBox.SetSelLength(const Value: Integer); begin TntCombo_SetSelLength(Self, Value); end; function TTntCustomDBComboBox.GetSelText: WideString; begin Result := TntCombo_GetSelText(Self); end; procedure TTntCustomDBComboBox.SetSelText(const Value: WideString); begin TntCombo_SetSelText(Self, Value); end; function TTntCustomDBComboBox.GetText: WideString; begin Result := TntControl_GetText(Self); end; procedure TTntCustomDBComboBox.SetText(const Value: WideString); begin TntControl_SetText(Self, Value); end; procedure TTntCustomDBComboBox.CNCommand(var Message: TWMCommand); begin if not TntCombo_CNCommand(Self, Items, Message) then inherited; end; function TTntCustomDBComboBox.GetFieldValue: Variant; begin Result := Field.Value; end; procedure TTntCustomDBComboBox.SetFieldValue(const Value: Variant); begin Field.Value := Value; end; procedure TTntCustomDBComboBox.DataChange(Sender: TObject); begin if not (Style = csSimple) and DroppedDown then Exit; if Field <> nil then SetComboValue(GetFieldValue) else if csDesigning in ComponentState then SetComboValue(Name) else SetComboValue(Null); end; procedure TTntCustomDBComboBox.UpdateData(Sender: TObject); begin SetFieldValue(GetComboValue); end; function TTntCustomDBComboBox.GetAutoComplete_PreserveDataEntryCase: Boolean; begin Result := True; end; function TTntCustomDBComboBox.GetAutoComplete_UniqueMatchOnly: Boolean; begin Result := False; end; function TTntCustomDBComboBox.IsHintStored: Boolean; begin Result := TntControl_IsHintStored(Self); end; function TTntCustomDBComboBox.GetHint: WideString; begin Result := TntControl_GetHint(Self) end; procedure TTntCustomDBComboBox.SetHint(const Value: WideString); begin TntControl_SetHint(Self, Value); end; procedure TTntCustomDBComboBox.AddItem(const Item: WideString; AObject: TObject); begin TntComboBox_AddItem(Items, Item, AObject); end; procedure TTntCustomDBComboBox.CopySelection(Destination: TCustomListControl); begin TntComboBox_CopySelection(Items, ItemIndex, Destination); end; procedure TTntCustomDBComboBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); inherited; end; function TTntCustomDBComboBox.GetActionLinkClass: TControlActionLinkClass; begin Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); end; {$IFDEF DELPHI_7} // fix for Delphi 7 only function TTntCustomDBComboBox.GetItemsClass: TCustomComboBoxStringsClass; begin Result := TD7PatchedComboBoxStrings; end; {$ENDIF} { TTntDBComboBox } function TTntDBComboBox.GetFieldValue: Variant; begin Result := GetWideText(Field); end; procedure TTntDBComboBox.SetFieldValue(const Value: Variant); begin SetWideText(Field, Value); end; procedure TTntDBComboBox.SetComboValue(const Value: Variant); var I: Integer; Redraw: Boolean; OldValue: WideString; NewValue: WideString; begin OldValue := VarToWideStr(GetComboValue); NewValue := VarToWideStr(Value); if NewValue <> OldValue then begin if Style <> csDropDown then begin Redraw := (Style <> csSimple) and HandleAllocated; if Redraw then Items.BeginUpdate; try if NewValue = '' then I := -1 else I := Items.IndexOf(NewValue); ItemIndex := I; finally Items.EndUpdate; end; if I >= 0 then Exit; end; if Style in [csDropDown, csSimple] then Text := NewValue; end; end; function TTntDBComboBox.GetComboValue: Variant; var I: Integer; begin if Style in [csDropDown, csSimple] then Result := Text else begin I := ItemIndex; if I < 0 then Result := '' else Result := Items[I]; end; end; { TTntDBCheckBox } procedure TTntDBCheckBox.CreateWindowHandle(const Params: TCreateParams); begin CreateUnicodeHandle(Self, Params, 'BUTTON'); end; procedure TTntDBCheckBox.DefineProperties(Filer: TFiler); begin inherited; TntPersistent_AfterInherited_DefineProperties(Filer, Self); end; function TTntDBCheckBox.IsCaptionStored: Boolean; begin Result := TntControl_IsCaptionStored(Self); end; function TTntDBCheckBox.GetCaption: TWideCaption; begin Result := TntControl_GetText(Self) end; procedure TTntDBCheckBox.SetCaption(const Value: TWideCaption); begin TntControl_SetText(Self, Value); end; function TTntDBCheckBox.IsHintStored: Boolean; begin Result := TntControl_IsHintStored(Self); end; function TTntDBCheckBox.GetHint: WideString; begin Result := TntControl_GetHint(Self) end; procedure TTntDBCheckBox.SetHint(const Value: WideString); begin TntControl_SetHint(Self, Value); end; procedure TTntDBCheckBox.Toggle; var FDataLink: TDataLink; begin inherited; FDataLink := TDataLink(Perform(CM_GETDATALINK, 0, 0)) as TFieldDataLink; FDataLink.UpdateRecord; end; procedure TTntDBCheckBox.ActionChange(Sender: TObject; CheckDefaults: Boolean); begin TntControl_BeforeInherited_ActionChange(Self, Sender, CheckDefaults); inherited; end; function TTntDBCheckBox.GetActionLinkClass: TControlActionLinkClass; begin Result := TntControl_GetActionLinkClass(Self, inherited GetActionLinkClass); end; { TTntDBRichEdit } constructor TTntDBRichEdit.Create(AOwner: TComponent); begin inherited Create(AOwner); inherited ReadOnly := True; FAutoDisplay := True; FDataLink := TFieldDataLink.Create; FDataLink.Control := Self; FDataLink.OnDataChange := DataChange; FDataLink.OnEditingChange := EditingChange; FDataLink.OnUpdateData := UpdateData; end; destructor TTntDBRichEdit.Destroy; begin FDataLink.Free; FDataLink := nil; inherited Destroy; end; procedure TTntDBRichEdit.Loaded; begin inherited Loaded; if (csDesigning in ComponentState) then DataChange(Self) end; procedure TTntDBRichEdit.Notification(AComponent: TComponent; Operation: TOperation); begin inherited; if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil; end; function TTntDBRichEdit.UseRightToLeftAlignment: Boolean; begin Result := DBUseRightToLeftAlignment(Self, Field); end; procedure TTntDBRichEdit.BeginEditing; begin if not FDataLink.Editing then try if FieldIsBlobLike(Field) then FDataSave := Field.AsString{TNT-ALLOW AsString}; FDataLink.Edit; finally FDataSave := ''; end; end; procedure TTntDBRichEdit.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if FMemoLoaded then begin if (Key = VK_DELETE) or (Key = VK_BACK) or ((Key = VK_INSERT) and (ssShift in Shift)) or (((Key = Ord('V')) or (Key = Ord('X'))) and (ssCtrl in Shift)) then BeginEditing; end; end; procedure TTntDBRichEdit.KeyPress(var Key: AnsiChar); begin inherited KeyPress(Key); if FMemoLoaded then begin if (Key in [#32..#255]) and (Field <> nil) and not Field.IsValidChar(Key) then begin MessageBeep(0); Key := #0; end; case Key of ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: BeginEditing; #27: FDataLink.Reset; end; end else begin if Key = #13 then LoadMemo; Key := #0; end; end; procedure TTntDBRichEdit.Change; begin if FMemoLoaded then FDataLink.Modified; FMemoLoaded := True; inherited Change; end; procedure TTntDBRichEdit.CNNotify(var Message: TWMNotify); begin inherited; if Message.NMHdr^.code = EN_PROTECTED then Message.Result := 0 { allow the operation (otherwise the control might appear stuck) } end; function TTntDBRichEdit.GetDataSource: TDataSource; begin Result := FDataLink.DataSource; end; procedure TTntDBRichEdit.SetDataSource(Value: TDataSource); begin FDataLink.DataSource := Value; if Value <> nil then Value.FreeNotification(Self); end; function TTntDBRichEdit.GetDataField: WideString; begin Result := FDataLink.FieldName; end; procedure TTntDBRichEdit.SetDataField(const Value: WideString); begin FDataLink.FieldName := Value; end; function TTntDBRichEdit.GetReadOnly: Boolean; begin Result := FDataLink.ReadOnly; end; procedure TTntDBRichEdit.SetReadOnly(Value: Boolean); begin FDataLink.ReadOnly := Value; end; function TTntDBRichEdit.GetField: TField; begin Result := FDataLink.Field; end; procedure TTntDBRichEdit.InternalLoadMemo; var Stream: TStringStream{TNT-ALLOW TStringStream}; begin if PlainText then Text := GetAsWideString(Field) else begin Stream := TStringStream{TNT-ALLOW TStringStream}.Create(Field.AsString{TNT-ALLOW AsString}); try Lines.LoadFromStream(Stream); finally Stream.Free; end; end; end; procedure TTntDBRichEdit.LoadMemo; begin if not FMemoLoaded and Assigned(Field) and FieldIsBlobLike(Field) then begin try InternalLoadMemo; FMemoLoaded := True; except { Rich Edit Load failure } on E:EOutOfResources do Lines.Text := WideFormat('(%s)', [E.Message]); end; EditingChange(Self); end; end; procedure TTntDBRichEdit.DataChange(Sender: TObject); begin if Field <> nil then if FieldIsBlobLike(Field) then begin if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then begin { Check if the data has changed since we read it the first time } if (FDataSave <> '') and (FDataSave = Field.AsString{TNT-ALLOW AsString}) then Exit; FMemoLoaded := False; LoadMemo; end else begin Text := WideFormat('(%s)', [Field.DisplayName]); FMemoLoaded := False; end; end else begin if FFocused and FDataLink.CanModify then Text := GetWideText(Field) else Text := GetWideDisplayText(Field); FMemoLoaded := True; end else begin if csDesigning in ComponentState then Text := Name else Text := ''; FMemoLoaded := False; end; if HandleAllocated then RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); end; procedure TTntDBRichEdit.EditingChange(Sender: TObject); begin inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); end; procedure TTntDBRichEdit.InternalSaveMemo; var Stream: TStringStream{TNT-ALLOW TStringStream}; begin if PlainText then SetAsWideString(Field, Text) else begin Stream := TStringStream{TNT-ALLOW TStringStream}.Create(''); try Lines.SaveToStream(Stream); Field.AsString{TNT-ALLOW AsString} := Stream.DataString; finally Stream.Free; end; end; end; procedure TTntDBRichEdit.UpdateData(Sender: TObject); begin if FieldIsBlobLike(Field) then InternalSaveMemo else SetAsWideString(Field, Text); end; procedure TTntDBRichEdit.SetFocused(Value: Boolean); begin if FFocused <> Value then begin FFocused := Value; if not Assigned(Field) or not FieldIsBlobLike(Field) then FDataLink.Reset; end; end; procedure TTntDBRichEdit.CMEnter(var Message: TCMEnter); begin SetFocused(True); inherited; end; procedure TTntDBRichEdit.CMExit(var Message: TCMExit); begin try FDataLink.UpdateRecord; except SetFocus; raise; end; SetFocused(False); inherited; end; procedure TTntDBRichEdit.SetAutoDisplay(Value: Boolean); begin if FAutoDisplay <> Value then begin FAutoDisplay := Value; if Value then LoadMemo; end; end; procedure TTntDBRichEdit.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin if not FMemoLoaded then LoadMemo else inherited; end; procedure TTntDBRichEdit.WMCut(var Message: TMessage); begin BeginEditing; inherited; end; procedure TTntDBRichEdit.WMPaste(var Message: TMessage); begin BeginEditing; inherited; end; procedure TTntDBRichEdit.CMGetDataLink(var Message: TMessage); begin Message.Result := Integer(FDataLink); end; function TTntDBRichEdit.ExecuteAction(Action: TBasicAction): Boolean; begin Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and FDataLink.ExecuteAction(Action); end; function TTntDBRichEdit.UpdateAction(Action: TBasicAction): Boolean; begin Result := inherited UpdateAction(Action) or (FDataLink <> nil) and FDataLink.UpdateAction(Action); end; { TTntDBMemo } constructor TTntDBMemo.Create(AOwner: TComponent); begin inherited Create(AOwner); inherited ReadOnly := True; ControlStyle := ControlStyle + [csReplicatable]; FAutoDisplay := True; FDataLink := TFieldDataLink.Create; FDataLink.Control := Self; FDataLink.OnDataChange := DataChange; FDataLink.OnEditingChange := EditingChange; FDataLink.OnUpdateData := UpdateData; FPaintControl := TTntPaintControl.Create(Self, 'EDIT'); end; destructor TTntDBMemo.Destroy; begin FPaintControl.Free; FDataLink.Free; FDataLink := nil; inherited Destroy; end; procedure TTntDBMemo.Loaded; begin inherited Loaded; if (csDesigning in ComponentState) then DataChange(Self); end; procedure TTntDBMemo.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil; end; function TTntDBMemo.UseRightToLeftAlignment: Boolean; begin Result := DBUseRightToLeftAlignment(Self, Field); end; procedure TTntDBMemo.KeyDown(var Key: Word; Shift: TShiftState); begin inherited KeyDown(Key, Shift); if FMemoLoaded then begin if (Key = VK_DELETE) or ((Key = VK_INSERT) and (ssShift in Shift)) then FDataLink.Edit; end; end; procedure TTntDBMemo.KeyPress(var Key: Char{TNT-ALLOW Char}); begin inherited KeyPress(Key); if FMemoLoaded then begin if (Key in [#32..#255]) and (FDataLink.Field <> nil) and not FDataLink.Field.IsValidChar(Key) then begin MessageBeep(0); Key := #0; end; case Key of ^H, ^I, ^J, ^M, ^V, ^X, #32..#255: FDataLink.Edit; #27: FDataLink.Reset; end; end else begin if Key = #13 then LoadMemo; Key := #0; end; end; procedure TTntDBMemo.Change; begin if FMemoLoaded then FDataLink.Modified; FMemoLoaded := True; inherited Change; end; function TTntDBMemo.GetDataSource: TDataSource; begin Result := FDataLink.DataSource; end; procedure TTntDBMemo.SetDataSource(Value: TDataSource); begin if not (FDataLink.DataSourceFixed and (csLoading in ComponentState)) then FDataLink.DataSource := Value; if Value <> nil then Value.FreeNotification(Self); end; function TTntDBMemo.GetDataField: WideString; begin Result := FDataLink.FieldName; end; procedure TTntDBMemo.SetDataField(const Value: WideString); begin FDataLink.FieldName := Value; end; function TTntDBMemo.GetReadOnly: Boolean; begin Result := FDataLink.ReadOnly; end; procedure TTntDBMemo.SetReadOnly(Value: Boolean); begin FDataLink.ReadOnly := Value; end; function TTntDBMemo.GetField: TField; begin Result := FDataLink.Field; end; procedure TTntDBMemo.LoadMemo; begin if not FMemoLoaded and Assigned(FDataLink.Field) and FieldIsBlobLike(FDataLink.Field) then begin try Lines.Text := GetAsWideString(FDataLink.Field); FMemoLoaded := True; except { Memo too large } on E:EInvalidOperation do Lines.Text := WideFormat('(%s)', [E.Message]); end; EditingChange(Self); end; end; procedure TTntDBMemo.DataChange(Sender: TObject); begin if FDataLink.Field <> nil then if FieldIsBlobLike(FDataLink.Field) then begin if FAutoDisplay or (FDataLink.Editing and FMemoLoaded) then begin FMemoLoaded := False; LoadMemo; end else begin Text := WideFormat('(%s)', [FDataLink.Field.DisplayName]); FMemoLoaded := False; EditingChange(Self); end; end else begin if FFocused and FDataLink.CanModify then Text := GetWideText(FDataLink.Field) else Text := GetWideDisplayText(FDataLink.Field); FMemoLoaded := True; end else begin if csDesigning in ComponentState then Text := Name else Text := ''; FMemoLoaded := False; end; if HandleAllocated then RedrawWindow(Handle, nil, 0, RDW_INVALIDATE or RDW_ERASE or RDW_FRAME); end; procedure TTntDBMemo.EditingChange(Sender: TObject); begin inherited ReadOnly := not (FDataLink.Editing and FMemoLoaded); end; procedure TTntDBMemo.UpdateData(Sender: TObject); begin SetAsWideString(FDataLink.Field, Text); end; procedure TTntDBMemo.SetFocused(Value: Boolean); begin if FFocused <> Value then begin FFocused := Value; if not Assigned(FDataLink.Field) or not FieldIsBlobLike(FDataLink.Field) then FDataLink.Reset; end; end; procedure TTntDBMemo.WndProc(var Message: TMessage); begin with Message do if (Msg = WM_CREATE) or (Msg = WM_WINDOWPOSCHANGED) or (Msg = CM_FONTCHANGED) then FPaintControl.DestroyHandle; inherited; end; procedure TTntDBMemo.CMEnter(var Message: TCMEnter); begin SetFocused(True); inherited; end; procedure TTntDBMemo.CMExit(var Message: TCMExit); begin try FDataLink.UpdateRecord; except SetFocus; raise; end; SetFocused(False); inherited; end; procedure TTntDBMemo.SetAutoDisplay(Value: Boolean); begin if FAutoDisplay <> Value then begin FAutoDisplay := Value; if Value then LoadMemo; end; end; procedure TTntDBMemo.WMLButtonDblClk(var Message: TWMLButtonDblClk); begin if not FMemoLoaded then LoadMemo else inherited; end; procedure TTntDBMemo.WMCut(var Message: TMessage); begin FDataLink.Edit; inherited; end; procedure TTntDBMemo.WMUndo(var Message: TMessage); begin FDataLink.Edit; inherited; end; procedure TTntDBMemo.WMPaste(var Message: TMessage); begin FDataLink.Edit; inherited; end; procedure TTntDBMemo.CMGetDataLink(var Message: TMessage); begin Message.Result := Integer(FDataLink); end; procedure TTntDBMemo.WMPaint(var Message: TWMPaint); var S: WideString; begin if not (csPaintCopy in ControlState) then inherited else begin if FDataLink.Field <> nil then if FieldIsBlobLike(FDataLink.Field) then begin if FAutoDisplay then S := TntAdjustLineBreaks(GetAsWideString(FDataLink.Field)) else S := WideFormat('(%s)', [FDataLink.Field.DisplayName]); end else S := GetWideDisplayText(FDataLink.Field); if (not Win32PlatformIsUnicode) then SendMessageA(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PAnsiChar(AnsiString(S)))) else begin SendMessageW(FPaintControl.Handle, WM_SETTEXT, 0, Integer(PWideChar(S))); end; SendMessage(FPaintControl.Handle, WM_ERASEBKGND, Integer(Message.DC), 0); SendMessage(FPaintControl.Handle, WM_PAINT, Integer(Message.DC), 0); end; end; function TTntDBMemo.ExecuteAction(Action: TBasicAction): Boolean; begin Result := inherited ExecuteAction(Action) or (FDataLink <> nil) and FDataLink.ExecuteAction(Action); end; function TTntDBMemo.UpdateAction(Action: TBasicAction): Boolean; begin Result := inherited UpdateAction(Action) or (FDataLink <> nil) and FDataLink.UpdateAction(Action); end; { TTntDBRadioGroup } constructor TTntDBRadioGroup.Create(AOwner: TComponent); begin inherited Create(AOwner); FDataLink := TFieldDataLink.Create; FDataLink.Control := Self; FDataLink.OnDataChange := DataChange; FDataLink.OnUpdateData := UpdateData; FValues := TTntStringList.Create; end; destructor TTntDBRadioGroup.Destroy; begin FDataLink.Free; FDataLink := nil; FValues.Free; inherited Destroy; end; procedure TTntDBRadioGroup.Notification(AComponent: TComponent; Operation: TOperation); begin inherited Notification(AComponent, Operation); if (Operation = opRemove) and (FDataLink <> nil) and (AComponent = DataSource) then DataSource := nil; end; function TTntDBRadioGroup.UseRightToLeftAlignment: Boolean; begin Result := inherited UseRightToLeftAlignment; end; procedure TTntDBRadioGroup.DataChange(Sender: TObject); begin if FDataLink.Field <> nil then Value := GetWideText(FDataLink.Field) else Value := ''; end; procedure TTntDBRadioGroup.UpdateData(Sender: TObject); begin if FDataLink.Field <> nil then SetWideText(FDataLink.Field, Value); end; function TTntDBRadioGroup.GetDataSource: TDataSource; begin Result := FDataLink.DataSource; end; procedure TTntDBRadioGroup.SetDataSource(Value: TDataSource); begin FDataLink.DataSource := Value; if Value <> nil then Value.FreeNotification(Self); end; function TTntDBRadioGroup.GetDataField: WideString; begin Result := FDataLink.FieldName; end; procedure TTntDBRadioGroup.SetDataField(const Value: WideString); begin FDataLink.FieldName := Value; end; function TTntDBRadioGroup.GetReadOnly: Boolean; begin Result := FDataLink.ReadOnly; end; procedure TTntDBRadioGroup.SetReadOnly(Value: Boolean); begin FDataLink.ReadOnly := Value; end; function TTntDBRadioGroup.GetField: TField; begin Result := FDataLink.Field; end; function TTntDBRadioGroup.GetButtonValue(Index: Integer): WideString; begin if (Index < FValues.Count) and (FValues[Index] <> '') then Result := FValues[Index] else if Index < Items.Count then Result := Items[Index] else Result := ''; end; procedure TTntDBRadioGroup.SetValue(const Value: WideString); var WasFocused: Boolean; I, Index: Integer; begin if FValue <> Value then begin FInSetValue := True; try WasFocused := (ItemIndex > -1) and (Buttons[ItemIndex].Focused); Index := -1; for I := 0 to Items.Count - 1 do if Value = GetButtonValue(I) then begin Index := I; Break; end; ItemIndex := Index; // Move the focus rect along with the selected index if WasFocused then Buttons[ItemIndex].SetFocus; finally FInSetValue := False; end; FValue := Value; Change; end; end; procedure TTntDBRadioGroup.CMExit(var Message: TCMExit); begin try FDataLink.UpdateRecord; except if ItemIndex >= 0 then (Controls[ItemIndex] as TTntRadioButton).SetFocus else (Controls[0] as TTntRadioButton).SetFocus; raise; end; inherited; end; procedure TTntDBRadioGroup.CMGetDataLink(var Message: TMessage); begin Message.Result := Integer(FDataLink); end; procedure TTntDBRadioGroup.Click; begin if not FInSetValue then begin inherited Click; if ItemIndex >= 0 then Value := GetButtonValue(ItemIndex); if FDataLink.Editing then FDataLink.Modified; end; end; procedure TTntDBRadioGroup.SetItems(Value: TTntStrings); begin Items.Assign(Value); DataChange(Self); end; procedure TTntDBRadioGroup.SetValues(Value: TTntStrings); begin FValues.Assign(Value); DataChange(Self); end; procedure TTntDBRadioGroup.Change; begin if Assigned(FOnChange) then FOnChange(Self); end; procedure TTntDBRadioGroup.KeyPress(var Key: Char{TNT-ALLOW Char}); begin inherited KeyPress(Key); case Key of #8, ' ': FDataLink.Edit; #27: FDataLink.Reset; end; end; function TTntDBRadioGroup.CanModify: Boolean; begin Result := FDataLink.Edit; end; function TTntDBRadioGroup.ExecuteAction(Action: TBasicAction): Boolean; begin Result := inherited ExecuteAction(Action) or (DataLink <> nil) and DataLink.ExecuteAction(Action); end; function TTntDBRadioGroup.UpdateAction(Action: TBasicAction): Boolean; begin Result := inherited UpdateAction(Action) or (DataLink <> nil) and DataLink.UpdateAction(Action); end; end.