tntdbctrlsex.pas

TntExUpdate 是 流行的 TntUnicodeControls控件的扩展包.包括很难找到的 TntJVCL 也在里面. TntSysUtils2.pas/TntSysUtilsEx.pa

{    06/22/2006 version
      TTntDBNavigator bug solved (changes in Hints in design):
        Loaded procedure has been added. Thanks to Thang Vu Quang }

unit TntDBCtrlsEx;

interface

{$I TntCompilers.inc}

uses
  Windows, Messages, Forms, Classes, Controls, TntStdCtrls, TntControls, DB,
  Buttons, DBCtrls, TntDB, TntDBCtrls, TntClasses, TntSysUtils, TntButtons,
  TntVer, TntDBCtrls2, StdCtrls, TntExtCtrls;

type
(*  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;*)

  TTntDBEditEx = class(TTntDBEditA)
  private
    procedure CMEnter(var Message: TCMEnter); message CM_ENTER;
  end;

  TTntDBNavigator = class(TDBNavigator)
  private
    FAbout: TAboutInfo;
    FCaptions: TTntStrings;
    FHints: TTntStrings;
    FDefHints: TTntStrings;
    FShowCaption: Boolean;
    FButtonLayout: TButtonLayout;
    procedure HintsChanged(Sender: TObject);
    procedure CaptionsChanged(Sender: TObject);
    function GetCaptions: TTntStrings;
    function GetHints: TTntStrings;
    procedure SetCaptions(const Value: TTntStrings);
    procedure SetHints(const Value: TTntStrings);
    procedure SetShowCaption(const Value: Boolean);
    procedure SetButtonLayout(const Value: TButtonLayout);
  protected
    property DefaultHints: TTntStrings read FDefHints;
    procedure InitButtons; virtual;
    procedure InitCaptions; virtual;
    procedure InitHints; virtual;
    procedure Loaded; override;
    property Captions: TTntStrings read GetCaptions write SetCaptions;
    property ShowCaption: Boolean read FShowCaption write SetShowCaption;
    property ButtonLayout: TButtonLayout read FButtonLayout write SetButtonLayout;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
  published
    property About: TAboutInfo read FAbout write FAbout stored False;
    property Hints: TTntStrings read GetHints write SetHints;
  end;

  TTntNavButton = class;
  TTntDBNavigatorEx = class(TTntDBNavigator)
  private
    function GetNavButton(Btn: TNavigateBtn): TTntNavButton;
  public
    property NavButtons[Btn: TNavigateBtn]: TTntNavButton read GetNavButton;
  published
    property Captions;
    property ShowCaption;
    property ButtonLayout;
  end;

  TTntNavButton = class(TNavButton, ITntGlyphButton)
  private
    FPaintInherited: Boolean;
    function GetCaption: TWideCaption;
    function GetHint: WideString;
    procedure SetCaption(const Value: TWideCaption);
    procedure SetHint(const Value: WideString);
    procedure CMHintShow(var Message: TMessage); message CM_HINTSHOW;
  protected
    procedure NavButtonPaint; virtual;
    procedure Paint; override;
    procedure UpdateInternalGlyphList; dynamic;
    function GetButtonGlyph: Pointer;
  public
    property Caption: TWideCaption read GetCaption write SetCaption;
    property Hint: WideString read GetHint write SetHint;
  end;

(*{ TTntDBCheckBox }

  TTntDBCheckBox = class(TTntCustomCheckBox)
  private
    FDataLink: TFieldDataLink;
    FValueCheck: WideString;
    FValueUncheck: WideString;
    FPaintControl: TTntPaintControl;
    procedure DataChange(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetFieldState: TCheckBoxState;
    function GetReadOnly: Boolean;
    procedure SetDataField(const Value: string);
    procedure SetDataSource(Value: TDataSource);
    procedure SetReadOnly(Value: Boolean);
    procedure SetValueCheck(const Value: WideString);
    procedure SetValueUncheck(const Value: WideString);
    procedure UpdateData(Sender: TObject);
    function ValueMatch(const ValueList, Value: WideString): Boolean;
    procedure WMPaint(var Message: TWMPaint); message WM_PAINT;
    procedure CMExit(var Message: TCMExit); message CM_EXIT;
    procedure CMGetDataLink(var Message: TMessage); message CM_GETDATALINK;
  protected
    procedure Toggle; override;
    procedure KeyPress(var Key: Char); 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;
    function UpdateAction(Action: TBasicAction): Boolean; override;
    function UseRightToLeftAlignment: Boolean; override;
    property Checked;
    property Field: TField read GetField;
    property State;
  published
    property Action;
    property Alignment;
    property AllowGrayed;
    property Anchors;
    property BiDiMode;
    property Caption;
    property Color;
    property Constraints;
    property Ctl3D;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write SetDataSource;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    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 ValueChecked: WideString read FValueCheck write SetValueCheck;
    property ValueUnchecked: WideString read FValueUncheck write SetValueUncheck;
    property Visible;
    property WordWrap;
    property OnClick;
    property OnContextPopup;
    property OnDragDrop;
    property OnDragOver;
    property OnEndDock;
    property OnEndDrag;
    property OnEnter;
    property OnExit;
    property OnKeyDown;
    property OnKeyPress;
    property OnKeyUp;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;*)

(*  TTntDBRadioGroup = class(TTntCustomRadioGroup)
  private
    FDataLink: TFieldDataLink;
    FValue: WideString;
    FValues: TTntStrings;
    FInSetValue: Boolean;
    FOnChange: TNotifyEvent;
    procedure DataChange(Sender: TObject);
    procedure UpdateData(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    function GetButtonValue(Index: Integer): WideString;
    procedure SetDataField(const Value: string);
    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); 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: string 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;
    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;
    property OnStartDock;
    property OnStartDrag;
  end;*)

(*
  TTntDBMemo = class(TTntCustomMemo)
  private
    FDataLink: TFieldDataLink;
    FAutoDisplay: Boolean;
    FFocused: Boolean;
    FMemoLoaded: Boolean;
    FPaintControl: TTntPaintControl;
    procedure DataChange(Sender: TObject);
    procedure EditingChange(Sender: TObject);
    function GetDataField: string;
    function GetDataSource: TDataSource;
    function GetField: TField;
    function GetReadOnly: Boolean;
    procedure SetDataField(const Value: string);
    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); 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 BiDiMode;
    property BorderStyle;
    property Color;
    property Constraints;
    property Ctl3D;
    property DataField: string read GetDataField write SetDataField;
    property DataSource: TDataSource read GetDataSource write
      SetDataSource;
    property DragCursor;
    property DragKind;
    property DragMode;
    property Enabled;
    property Font;
    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 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;
    property OnMouseDown;
    property OnMouseMove;
    property OnMouseUp;
    property OnStartDock;
    property OnStartDrag;
  end;*)

function WideExtractFieldName(const Fields: WideString; var Pos: Integer): WideString;

implementation

uses
  TntSystem, SysUtils, {$IFDEF COMPILER_6_UP}VDBConsts, {$ENDIF}Graphics, ExtCtrls,
{$IFDEF COMPILER_7_UP}Themes,{$ENDIF} DBConsts;

function WideExtractFieldName(const Fields: WideString; var Pos: Integer): WideString;
var
  I: Integer;
begin
  I := Pos;
  while (I <= Length(Fields)) and (Fields[I] <> ';') do Inc(I);
  Result := Trim(Copy(Fields, Pos, I - Pos));
  if (I <= Length(Fields)) and (Fields[I] = ';') then Inc(I);
  Pos := I;
end;

(*
type
  TWinControlAccess = 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);
  FreeObjectInstance(FObjectInstance);
  FHandle := 0;
  FObjectInstance := nil;
end;

function TTntPaintControl.GetHandle: HWnd;
var
  Params: TCreateParams;
begin
  if FHandle = 0 then
  begin
    FObjectInstance := MakeObjectInstance(WndProc);
    TWinControlAccess(FOwner).CreateParams(Params);
    Params.Style := Params.Style and not (WS_HSCROLL or WS_VSCROLL);
    if Win32PlatformIsUnicode then
    begin
      with Params do
        FHandle := CreateWindowExW(ExStyle,
          PWideChar(WideString(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
    else
    begin
      with Params do
        FHandle := CreateWindowEx(ExStyle, PChar(string(FClassName)),
          PChar(TWinControlAccess(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;
    SendMessage(FHandle, WM_SETFONT,
      TWinControlAccess(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 Win32PlatformIsUnicode then
      Result := CallWindowProcW(FDefWindowProc, FHandle, Msg, WParam,
        LParam)
    else
      Result := CallWindowProc(FDefWindowProc, FHandle, Msg, WParam,
        LParam)
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);
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);