tntdbctrls.pas

TNT Components Source

  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: