tntdb.pas

TNTUniCtrlsWithExceptions UniCode 国际化语言

    if Field.IsNull then
      // This fixes a bug in TWideStringField.GetAsWideString which does not handle Null at all.
      Result := ''
    else
      Result := TWideStringField{TNT-ALLOW TWideStringField}(Field).Value
  end else if (Field is TMemoField{TNT-ALLOW TMemoField}) then
    Result := VarToWideStr(Field.AsVariant) { works for NexusDB BLOB Wide }
  else
    Result := Field.AsString{TNT-ALLOW AsString};
end;
{$ENDIF}

procedure SetAsWideString(Field: TField; const Value: WideString);
{$IFDEF COMPILER_10_UP}
begin
  if (Field.ClassType = TMemoField{TNT-ALLOW TMemoField}) then
    Field.AsVariant := Value { works for NexusDB BLOB Wide }
  else
    Field.AsWideString := Value;
end;
{$ELSE}
var
  WideField: IWideStringField;
begin
  if Field.GetInterface(IWideStringField, WideField) then
    WideField.AsWideString := Value
  else if (Field is TWideStringField{TNT-ALLOW TWideStringField}) then
    TWideStringField{TNT-ALLOW TWideStringField}(Field).Value := Value
  else if (Field is TMemoField{TNT-ALLOW TMemoField}) then
    Field.AsVariant := Value { works for NexusDB BLOB Wide }
  else
    Field.AsString{TNT-ALLOW AsString} := Value;
end;
{$ENDIF}

function GetWideDisplayText(Field: TField): WideString;
var
  WideField: IWideStringField;
begin
  if Field.GetInterface(IWideStringField, WideField) then
    Result := WideField.WideDisplayText
  else if (Field is TWideStringField{TNT-ALLOW TWideStringField})
  and (not Assigned(Field.OnGetText)) then
    Result := GetAsWideString(Field)
  else
    Result := Field.DisplayText{TNT-ALLOW DisplayText};
end;

function GetWideText(Field: TField): WideString;
var
  WideField: IWideStringField;
begin
  if Field.GetInterface(IWideStringField, WideField) then
    Result := WideField.WideText
  else if (Field is TWideStringField{TNT-ALLOW TWideStringField})
  and (not Assigned(Field.OnGetText)) then
    Result := GetAsWideString(Field)
  else
    Result := Field.Text;
end;

procedure SetWideText(Field: TField; const Value: WideString);
var
  WideField: IWideStringField;
begin
  if Field.GetInterface(IWideStringField, WideField) then
    WideField.WideText := Value
  else if (Field is TWideStringField{TNT-ALLOW TWideStringField})
  and (not Assigned(Field.OnSetText)) then
    SetAsWideString(Field, Value)
  else
    Field.Text := Value
end;

{ TTntDateTimeField }

procedure TTntDateTimeField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToDateTime(Value));
end;

{ TTntDateField }

procedure TTntDateField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToDate(Value));
end;

{ TTntTimeField }

procedure TTntTimeField.SetAsString(const Value: AnsiString);
begin
  if Value = '' then
    inherited
  else
    SetAsDateTime(TntStrToTime(Value));
end;

{ TTntWideStringField / TTntStringField common handlers }

procedure TntWideStringField_LegacyGetText(Sender: TField; OnGetText: TFieldGetWideTextEvent;
  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 TntWideStringField_LegacySetText(Sender: TField; OnSetText: TFieldSetWideTextEvent;
  const AnsiText: AnsiString);
begin
  if Assigned(OnSetText) then
    OnSetText(Sender, AnsiText);
end;

procedure TntWideStringField_GetWideText(Field: TField;
  var Text: WideString; DoDisplayText: Boolean);
var
  WideStringField: IWideStringField;
begin
  Field.GetInterface(IWideStringField, WideStringField);
  Assert(WideStringField <> nil);
  if DoDisplayText and (Field.EditMaskPtr <> '') then
    { to gain the mask, we lose Unicode! }
    Text := FormatMaskText(Field.EditMaskPtr, GetAsWideString(Field))
  else
    Text := GetAsWideString(Field);
end;

function TntWideStringField_GetWideDisplayText(Field: TField;
  OnGetText: TFieldGetWideTextEvent): WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Field, Result, True)
  else if Assigned(Field.OnGetText) then
    Result := Field.DisplayText{TNT-ALLOW DisplayText} {we lose Unicode to handle this event}
  else
    TntWideStringField_GetWideText(Field, Result, True);
end;

function TntWideStringField_GetWideEditText(Field: TField;
  OnGetText: TFieldGetWideTextEvent): WideString;
begin
  Result := '';
  if Assigned(OnGetText) then
    OnGetText(Field, Result, False)
  else if Assigned(Field.OnGetText) then
    Result := Field.Text {we lose Unicode to handle this event}
  else
    TntWideStringField_GetWideText(Field, Result, False);
end;

procedure TntWideStringField_SetWideText(Field: TField;
  const Value: WideString);
{$IFDEF COMPILER_10_UP}
begin
  Field.AsWideString := Value;
end;
{$ELSE}
var
  WideStringField: IWideStringField;
begin
  Field.GetInterface(IWideStringField, WideStringField);
  Assert(WideStringField <> nil);
  WideStringField.SetAsWideString(Value);
end;
{$ENDIF}

procedure TntWideStringField_SetWideEditText(Field: TField;
  OnSetText: TFieldSetWideTextEvent; const Value: WideString);
begin
  if Assigned(OnSetText) then
    OnSetText(Field, Value)
  else if Assigned(Field.OnSetText) then
    Field.Text := Value {we lose Unicode to handle this event}
  else
    TntWideStringField_SetWideText(Field, Value);
end;

{ TTntWideStringField }

{$IFNDEF COMPILER_10_UP}
function TTntWideStringField.GetAsWideString: WideString;
begin
  if not GetData(@Result, False) then
    Result := ''; {fixes a bug in inherited which has unpredictable results for NULL}
end;
{$ENDIF}

procedure TTntWideStringField.LegacyGetText(Sender: TField; var AnsiText: AnsiString;
  DoDisplayText: Boolean);
begin
  TntWideStringField_LegacyGetText(Sender, OnGetText, AnsiText, DoDisplayText);
end;

procedure TTntWideStringField.LegacySetText(Sender: TField; const AnsiText: AnsiString);
begin
  TntWideStringField_LegacySetText(Sender, OnSetText, AnsiText);
end;

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

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

function TTntWideStringField.GetWideDisplayText: WideString;
begin
  Result := TntWideStringField_GetWideDisplayText(Self, OnGetText);
end;

function TTntWideStringField.GetWideEditText: WideString;
begin
  Result := TntWideStringField_GetWideEditText(Self, OnGetText);
end;

procedure TTntWideStringField.SetWideEditText(const Value: WideString);
begin
  TntWideStringField_SetWideEditText(Self, OnSetText, Value);
end;

(* This stuffing method works with CJK codepages - intended to store accented characters in Access 97 *)

function SafeStringToWideStringEx(const S: AnsiString; Codepage: Word): WideString;
var
  R: AnsiString;
  i: Integer;
begin
  R := '';
  i := 1;
  while i <= Length(S) do
  begin
    if (S[i] = #128) then
    begin
      Inc(i);
      if S[i] = #128 then
        R := R + #128
      else
        R := R + Chr(Ord(S[i]) + 128);
      Inc(i);
    end
    else
    begin
      R := R + S[I];
      Inc(i);
    end;
  end;
  Result := StringToWideStringEx(R, CodePage);
end;

function SafeWideStringToStringEx(const W: WideString; CodePage: Word): AnsiString;
var
  TempS: AnsiString;
  i: integer;
begin
  TempS := WideStringToStringEx(W, CodePage);
  Result := '';
  for i := 1 to Length(TempS) do
  begin
    if TempS[i] > #128 then
      Result := Result + #128 + Chr(Ord(TempS[i]) - 128)
    else if TempS[i] = #128 then
      Result := Result + #128 + #128
    else
      Result := Result + TempS[i];
  end;
end;

{ TTntStringField }

constructor TTntStringField.Create(AOwner: TComponent);
begin
  inherited;
  FEncodingMode := emUTF8;
  FFixedCodePage := TntStringFieldCodePageEnumMap[fcpLatinWestern]
end;

function TTntStringField.GetFixedCodePageEnum: TTntStringFieldCodePageEnum;