tntdbex.pas

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

unit TntDbEx;

interface

{$I TntCompilers.INC}
{ 27/08/2006 version:
  TTntCalcWideStringField is deleted because not running correctly,
    look at TntJvDBGridSDemoU a solution
  TTntMemoField is deleted because already exists in TntDB }

uses
  DB, SysUtils, Classes, TntDB, TntClasses, TntSysUtilsEx;

type
  (***  Use WideString in calculated fields
  TTntCalcWideStringField = class(TTntWideStringField)
  protected
     function GetDataSize: Integer; override;
 {$IFDEF COMPILER_5}
    function GetAsWideString: WideString;
    procedure SetAsWideString(const Value: WideString);
  public
    constructor Create(AOwner: TComponent); override;
 {$ENDIF}
  end;
  ***)

  TTntBlobWideStringField = class(TBlobField, IWideStringField)
  private
    FOnGetText: TFieldGetWideTextEvent;
    FOnSetText: TFieldSetWideTextEvent;
    procedure LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean); procedure LegacySetText(Sender: TField; const AnsiText: AnsiString);
    procedure SetOnGetText(const Value: TFieldGetWideTextEvent);
    procedure SetOnSetText(const Value: TFieldSetWideTextEvent);
  protected
    procedure SetAsString(const Value: string); override;
    function GetAsString: string; override;
    function GetWideDisplayText: WideString;
    function GetWideEditText: WideString;
    procedure SetWideEditText(const Value: WideString);
    function GetAsWideString: WideString; virtual;
    procedure SetAsWideString(const Value: WideString); virtual;
  public
    property AsWideString: WideString read GetAsWideString write SetAsWideString;
  published
    property OnGetText: TFieldGetWideTextEvent read FOnGetText write SetOnGetText;
    property OnSetText: TFieldSetWideTextEvent read FOnSetText write SetOnSetText;
  end;

  EWideDatabaseError = class(EWideException)
  end;

procedure RegisterTntFieldsEx;
procedure WideDatabaseError(const Message: WideString; Component: TComponent = nil);
procedure WideDatabaseErrorFmt(const Message: WideString; const Args: array of const;
  Component: TComponent = nil);
procedure WideLoadDataColumn(Items: TTntStrings; D: TDataSet; const Fieldname: string);
procedure WideLoadDataColumnValues(Items, Values: TTntStrings; DataSet: TDataSet;
  const FieldName, FieldValueName: string);

implementation

(* TTntCalcWideStringField *)
(***
{$IFDEF COMPILER_5}

constructor TTntCalcWideStringField.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  SetDataType(ftString);
end;

function TTntCalcWideStringField.GetAsWideString: WideString;
begin
  SetDataType(ftWideString);
  try
    Result := inherited GetAsWideString;
  finally
    SetDataType(ftString);
  end;
end;

procedure TTntCalcWideStringField.SetAsWideString(const Value: WideString);
begin
  SetDataType(ftWideString);
  try
    inherited SetAsWideString(Value);
  finally
    SetDataType(ftString);
  end;
end;
{$ENDIF}

function TTntCalcWideStringField.GetDataSize: Integer;
begin
  Result := (Size + 1) * 2; // used for MemoryData
end;
**)

(* TTntBlobWideStringField *)

function TTntBlobWideStringField.GetAsString: string;
begin
  Result := GetAsWideString;
end;

function TTntBlobWideStringField.GetAsWideString: WideString;
var
  Len: Integer;
begin
  with DataSet.CreateBlobStream(Self, bmRead) do
  try
    Len := Size div 2;
    SetLength(Result, Len);
    if Length(Result) > 0 then
      ReadBuffer(PWideChar(Result)^, Size);
  finally
    Free;
  end;
end;

function TTntBlobWideStringField.GetWideDisplayText: WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Self, Result, True)
  else if Assigned(inherited OnGetText) then
    Result := inherited DisplayText {TNT-ALLOW DisplayText} {we lose Unicode to handle this event}
  else
    Result := GetAsWideString;
end;

function TTntBlobWideStringField.GetWideEditText: WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Self, Result, False)
  else if Assigned(inherited OnGetText) then
    Result := inherited Text
  else
    Result := GetAsWideString;
end;

procedure TTntBlobWideStringField.SetWideEditText(const Value: WideString);
begin
  if Assigned(OnSetText) then
    OnSetText(Self, Value)
  else if Assigned(inherited OnSetText) then
    inherited Text := Value
  else
    SetAsWideString(Value);
end;

procedure TTntBlobWideStringField.SetAsString(const Value: string);
begin
  SetAsWideString(Value);
end;

procedure TTntBlobWideStringField.SetAsWideString(const Value: WideString);
begin
  with DataSet.CreateBlobStream(Self, bmWrite) do
  try
    WriteBuffer(PWideChar(Value)^, Length(Value) * 2);
  finally
    Free;
  end;
end;

procedure TTntBlobWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString; DoDisplayText: Boolean);
var
  WideText: WideString;
begin
  if Assigned(OnGetText) then
  begin
    WideText := AnsiText;
    OnGetText(Sender, WideText, DoDisplayText);
    AnsiText := WideText;
  end;
end;

procedure TTntBlobWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString);
begin
  if Assigned(OnSetText) then
    OnSetText(Sender, AnsiText);
end;

procedure TTntBlobWideStringField.SetOnGetText(
  const Value: TFieldGetWideTextEvent);
begin
  FOnGetText := Value;
  if Assigned(OnGetText) then
    inherited OnGetText := LegacyGetText
  else
    inherited OnGetText := nil;
end;

procedure TTntBlobWideStringField.SetOnSetText(
  const Value: TFieldSetWideTextEvent);
begin
  FOnSetText := Value;
  if Assigned(OnSetText) then
    inherited OnSetText := LegacySetText
  else
    inherited OnSetText := nil;
end;

procedure WideDatabaseError(const Message: WideString; Component: TComponent = nil);
begin
  if Assigned(Component) and (Component.Name <> '') then
    raise EWideDatabaseError.Create(WideFormat('%s: %s', [Component.Name, Message])) else
    raise EWideDatabaseError.Create(Message);
end;

procedure WideDatabaseErrorFmt(const Message: WideString; const Args: array of const;
  Component: TComponent = nil);
begin
  WideDatabaseError(WideFormat(Message, Args), Component);
end;

procedure WideLoadDataColumn(Items: TTntStrings; D: TDataSet; const Fieldname: string);
var
  F: TField;
begin
  F := D.FieldByName(FieldName);
  D.DisableControls;
  try
    D.First;
    while not D.EOF do
    begin
      Items.Add(GetAsWideString(F));
      D.Next;
    end;
  finally
    D.EnableControls;
  end;
end;

procedure WideLoadDataColumnValues(Items, Values: TTntStrings; DataSet: TDataSet;
  const FieldName, FieldValueName: string);
var
  F, FV: TField;
begin
  F := DataSet.FieldByName(FieldName);
  FV := DataSet.FieldByName(FieldValueName);
  Values.BeginUpdate;
  Items.BeginUpdate;
  DataSet.DisableControls;
  try
    DataSet.First;
    while not DataSet.EOF do
    begin
      Values.Add(GetAsWideString(FV));
      Items.Add(GetAsWideString(F));
      DataSet.Next;
    end;
  finally
    Values.EndUpdate;
    Items.EndUpdate;
    DataSet.EnableControls;
  end;
end;


procedure RegisterTntFieldsEx;
begin
  RegisterFields([TTntMemoField]);
  RegisterFields([TTntBlobWideStringField]);
end;


end.