tntadodb.pas

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

  FieldDef: TFieldDef;
begin
  inherited;
  for f := 0 to FieldDefs.Count - 1 do begin
    FieldDef := FieldDefs[f];
    if FieldDef.DataType = ftMemo then begin
      FieldDef.DataType := ftWideString;
      FieldDef.Size := MaxInt;
    end;
  end;
end;

procedure TTntCustomADODataSet.UpdateIndexDefs;
begin
  UpdateIndexDefs_FixedForAdo27;
end;

procedure TTntCustomADODataSet.DoBeforeOpen;
begin
  inherited;
end;

procedure TTntCustomADODataSet.DoAfterOpen;
begin
  inherited;
end;

procedure TTntCustomADODataSet.OpenCursor(InfoQuery: Boolean);
begin
  inherited;
end;

procedure TTntCustomADODataSet.DoAfterClose;
begin
  inherited;
end;

procedure TTntCustomADODataSet.DoAfterInsert;
begin
  inherited;
end;

function TTntCustomADODataSet.GetFieldData(Field: TField; Buffer: Pointer): Boolean;
begin
  Result := GetFieldData(Field, Buffer, True);
    { possibly the same as inherited, but we must make sure }
end;

function TTntCustomADODataSet.GetFieldData(Field: TField; Buffer: Pointer; NativeFormat:
  Boolean): Boolean;
begin
  result := inherited GetFieldData(Field, Buffer, NativeFormat);
  if (not result) and (Buffer <> nil) and (Field.DataType = ftWideString) then
    WideString(Buffer^) := '';
      { TWideStringField.GetAsWideString should do this for NULL values }
end;

function TTntCustomADODataSet.GetFieldData(FieldNo: Integer; Buffer: Pointer): Boolean;
begin
  Result := GetFieldData(FieldByNumber(FieldNo), Buffer);
    { possibly the same as inherited, but we must make sure }
end;

procedure TTntCustomADODataSet.SetFieldData(Field: TField; Buffer: Pointer);
begin
  SetFieldData(Field, Buffer, True) { possibly the same as inherited, but we must make sure }
end;

procedure TTntCustomADODataSet.SetFieldData(Field: TField; Buffer: Pointer; NativeFormat:
  Boolean);
begin
  if SetFieldData_IsNeeded(Field, Buffer, NativeFormat) then
    inherited; { only call inherited if a change is made }
end;

//=============================================================================================
//============                       UTIL PROCS                            ====================
//=============================================================================================

procedure TTntCustomADODataSet.UpdateIndexDefs_FixedForAdo27;
//  As of ADO 2.7, OpenSchema(adSchemaIndexes,...) no longer supports the
//    ORDINAL_POSITION column, but this can be determined by the sequence of
//      rows returned where the INDEX_NAME column is the same.
//        This new approach is backward compatible.
const
  cfIndex = 3;
const
  SUnique = 'UNIQUE'; { Do not localize + 5 }
  SIndexName = 'INDEX_NAME';
  SColumnName = 'COLUMN_NAME';
  SPrimaryKey = 'PRIMARY_KEY';
  SAutoUpdate = 'AUTO_UPDATE';
var
  IndexInfo: _Recordset;
begin
  try
    FieldDefs.Update;
    IndexDefs.Clear;
    if (CommandType in [cmdTable, cmdTableDirect]) and (CommandText <> '') then
    begin
      SetConnectionFlag(cfIndex, True);
      try
        IndexInfo := TAccessADOCommand(Command).ActiveConnection.OpenSchema(adSchemaIndexes,
          VarArrayOf([Unassigned, Unassigned, Unassigned, Unassigned, CommandText]),
          EmptyParam);
        while not IndexInfo.EOF do
        begin
          if IndexDefs.IndexOf(VarToWideStr(IndexInfo.Fields[SIndexName].Value)) <> -1 then
            with IndexDefs.Find(VarToWideStr(IndexInfo.Fields[SIndexName].Value)) do
              Fields := WideFormat('%s;%s', [Fields, IndexInfo.Fields[SColumnName].Value])
          else
            with IndexDefs.AddIndexDef do
            begin
              Name := VarToWideStr(IndexInfo.Fields[SIndexName].Value);
              Fields := VarToWideStr(IndexInfo.Fields[SColumnName].Value);
              if IndexInfo.Fields[SPrimaryKey].Value = True then
                Options := Options + [ixPrimary];
              if IndexInfo.Fields[SUnique].Value = True then
                Options := Options + [ixUnique];
              if IndexInfo.Fields[SAutoUpdate].Value = False then
                Options := Options + [ixNonMaintained];
            end;
          IndexInfo.MoveNext;
        end;
      finally
        SetConnectionFlag(cfIndex, False);
      end;
    end;
  except
    { do nothing }
  end;
end;

function DbCompareString(DbString: WideString; const KeyString: WideString; Options:
  TLocateOptions): Integer;
begin
  // handle loPartialKey, by shortening KeyString to match DbString
  if (loPartialKey in Options) then begin
    if Length(DbString) > Length(KeyString) then
      SetLength(DBString, Length(KeyString))
  end;

  // handle loCaseInsensitive, by setting CompareFlags
  if (loCaseInsensitive in Options) then
    Result := WideCompareText(DbString, KeyString)
  else
    Result := WideCompareStr(DbString, KeyString);
end;

function NonArrayVariantsEqual(DbValue, KeyValue: Variant; Options: TLocateOptions = []):
  Boolean;
begin
  Assert((not VarIsArray(DbValue)) and (not VarIsArray(KeyValue)),
    'InternalError: Array type variants found.');
  try
    if Options = [] then begin
      // no options, compare variants directly
      if VarIsEmpty(DbValue) then
        Result := VarIsEmpty(KeyValue)
      else if VarIsNull(DbValue) then
        Result := VarIsNull(KeyValue)
      else if VarIsEmpty(KeyValue) or VarIsNull(KeyValue) then
        Result := False
      else begin
        //VT_DECIMAL is MS's Decimal variant type which is unsupported by Delphi 5/6/7
        //and we therefore have to convert it to varDouble for the comparison.
        //varCurrency could also be used but it has DbValue very limited precision.
        if TVarData(DbValue).VType = VT_DECIMAL then
          DbValue := VarAsType(DbValue, varDouble);
        if TVarData(KeyValue).VType = VT_DECIMAL then
          KeyValue := VarAsType(KeyValue, varDouble);
        // compare directly
        Result := (DbValue = KeyValue)
      end;
    end else begin
      // force WideString comparison with options
      Result := DbCompareString(DbValue, KeyValue, Options) = 0;
    end;
  except
    Result := False;
  end;
end;


function VariantsEqual(DbValues, KeyValues: Variant; Options: TLocateOptions = []): Boolean;
var
  i: Integer;
begin
  if (VarArrayDimCount(DbValues) <> VarArrayDimCount(KeyValues)) then
    // different array dim count
    Result := False
  else if not VarIsArray(DbValues) then
    // both are not array
    Result := NonArrayVariantsEqual(DbValues, KeyValues, Options)
  else if (VarArrayLowBound(DbValues, 1) <> VarArrayLowBound(KeyValues, 1))
    or (VarArrayHighBound(DbValues, 1) <> VarArrayHighBound(KeyValues, 1)) then
    // array, different bounds
    Result := False
  else begin
    // array, same dim count, same bounds
    Result := True; { assume equal }
    for i := VarArrayLowBound(DbValues, 1) to VarArrayHighBound(DbValues, 1) do begin
      if not VariantsEqual(DbValues[i], KeyValues[i]) then begin
        Result := False;
        break; { found one that is NOT equal }
      end;
    end;
  end;
end;


function TTntCustomADODataSet.SetFieldData_IsNeeded(Field: TField; Buffer: Pointer;
  NativeFormat: Boolean): Boolean;

  function CanConvertBufferToVar: Boolean;
  begin
    result := Field.DataType in
      [ftDate, ftTime, ftDateTime, ftBCD, ftLargeInt];
  end;

  function BufferToVar: Variant;
  begin
    Assert(Buffer <> nil, 'Buffer not assigned.');
    case Field.DataType of
      ftDate, ftTime, ftDateTime:
        if NativeFormat then
          DataConvert(Field, Buffer, @TVarData(result).VDate, False)
        else
          result := TDateTime(Buffer^);
      ftBCD:
        if NativeFormat then
          DataConvert(Field, Buffer, @TVarData(result).VCurrency, False)
        else
          result := Currency(Buffer^);
      ftLargeInt:
        begin
          TVarData(result).VType := VT_DECIMAL;
          Decimal(result).Lo64 := Int64(Buffer^);
        end;
    else
      raise ETntInternalError.Create('Internal Error: Unexpected data type.');
    end;
  end;

begin
  if Buffer = nil then
    result := not Field.IsNull { must set it to Null }
  else if Field.IsNull then
    result := True { must set to Non-Null }
  else begin
    // determine if new value is the same as the old one
    case Field.DataType of
      ftString, ftFixedChar, ftGuid:
        result := (PAnsiChar(Buffer) <> Field.AsString {TNT-ALLOW AsString});
      ftWideString:
        result := (WideString(Buffer^) <> GetAsWideString(Field));
      ftAutoInc, ftInteger:
        result := (LongInt(Buffer^) <> Field.AsInteger);
      ftSmallInt:
        result := (SmallInt(Buffer^) <> Field.AsInteger);
      ftWord:
        result := (Word(Buffer^) <> Field.AsInteger);
      ftBoolean:
        result := (WordBool(Buffer^) <> Field.AsBoolean);
      ftFloat, ftCurrency:
        result := (Double(Buffer^) <> Field.AsFloat);
    else
      result := (not CanConvertBufferToVar) or (not VariantsEqual(Field.Value, BufferToVar))
    end;
  end;
end;

constructor TTntADOQuery.Create(AOwner: TComponent);
begin
  inherited;
  FMacros := TParams.Create(Self);
  FSQL := TTntStringList.Create;
  FMacroChar := DefaultMacroChar;
  TTntStringList(FSQL).OnChange := PatternChanged;
  CommandType := cmdText;
  TAccessADOCommand(Command).CommandTextAlias := 'SQL'; { Do not localize }
end;

destructor TTntADOQuery.Destroy;
begin
  FMacros.Free;
  FSQL.Free;
  inherited;
end;

function TTntADOQuery.GetMacroCount: Word;
begin
  Result := FMacros.Count;
end;

function TTntADOQuery.GetMacros: TParams;
begin
  if FStreamPatternChanged then
  begin
    FStreamPatternChanged := False;
    PatternChanged(nil);
  end;
  Result := FMacros;
end;

function TTntADOQuery.GetSQL: TTntStrings;
begin
  Result := FSQL;
end;

function TTntADOQuery.MacroByName(const Value: string): TParam;
begin
  Result := FMacros.ParamByName(Value);
end;

procedure TTntADOQuery.CreateMacros(List: TParams; const Value: PWideChar);
begin
  CreateQueryParams(List, Value, True, WideChar(MacroChar), ['.']);
end;

procedure TTntADOQuery.ExpandMacros;
var
  ExpandedSQL: TTntStringList;
begin
  if not FPatternChanged and not FStreamPatternChanged and
    (MacroCount = 0) then
    Exit;
  ExpandedSQL := TTntStringList.Create;
  try
    Expand(ExpandedSQL);
    try
      inherited CommandText := ExpandedSQL.Text;
    except
    end;
  finally
    ExpandedSQL.Free;
  end;
end;


procedure TTntADOQuery.RecreateMacros;
var
  List: TParams;
begin
  if not (csReading in ComponentState) then
  begin
    List := TParams.Create(Self);
    try
      CreateMacros(List, PWideChar(FSQL.Text));
      List.AssignValues(FMacros);
      FMacros.Clear;
      FMacros.Assign(List);
    finally
      List.Free;
    end;
  end
  else
  begin
    FMacros.Clear;
    CreateMacros(FMacros, PWideChar(FSQL.Text));
  end;
end;

procedure TTntADOQuery.SetMacroChar(const Value: Char);
begin
  FMacroChar := Value;
end;

procedure TTntADOQuery.SetMacros(const Value: TParams);
begin
  FMacros.AssignValues(Value);
end;

procedure TTntADOQuery.SetSQL(const Value: TTntStrings);
begin
  TTntStringList(FSQL).OnChange := nil;
  FSQL.Assign(Value);
  TTntStringList(FSQL).OnChange := PatternChanged;
  PatternChanged(nil);
end;

procedure TTntADOQuery.PatternChanged(Sender: TObject);
begin
  if csLoading in ComponentState then
  begin
    FStreamPatternChanged := True;
    Exit;
  end;
  inherited Close;
  RecreateMacros;
  FPatternChanged := True;
  try
    ExpandMacros;
  finally
    FPatternChanged := False;
  end;
end;

procedure InitializeMasterFields(Dataset: TCustomADODataSet);
var
  I: Integer;
  MasterFieldList: string;
begin
  with TAccessCustomADODataSet(Dataset) do
    { Assign MasterFields from parameters as needed by the MasterDataLink }
    if (Parameters.Count > 0) and Assigned(MasterDataLink.DataSource) and
      Assigned(MasterDataLink.DataSource.DataSet) then
    begin
      for I := 0 to Parameters.Count - 1 do
        if (Parameters[I].Direction in [pdInput, pdInputOutput]) and
          (MasterDataLink.DataSource.DataSet.FindField(Parameters[I].Name) <> nil) then
          MasterFieldList := MasterFieldList + Parameters[I].Name + ';';
      MasterFields := Copy(MasterFieldList, 1, Length(MasterFieldList) - 1);
      SetParamsFromCursor;
    end;
end;

function TTntADOQuery.ExecSQL: Integer;
begin
  ExpandMacros;
  InitializeMasterFields(Self);
  Command.Execute(FRowsAffected, EmptyParam);
  Result := FRowsAffected;
end;

procedure TTntADOQuery.Expand(ToSQL: TTntStrings);

  function ReplaceString(const S: WideString): WideString;
  var
    I, J, P, LiteralChars: Integer;
    Param: TParam;
    Found: Boolean;
  begin
    Result := S;
    for I := Macros.Count - 1 downto 0 do
    begin
      Param := Macros[I];
      if Param.DataType = ftUnknown then
        Continue;
      repeat
        P := Pos(MacroChar + Param.Name, Result);
        Found := (P > 0) and ((Length(Result) = P + Length(Param.Name)) or
          NameDelimiter(Result[P + Length(Param.Name) + 1], ['.']));
        if Found then
        begin
          LiteralChars := 0;
          for J := 1 to P - 1 do
            if IsLiteral(Result[J]) then
              Inc(LiteralChars);
          Found := LiteralChars mod 2 = 0;
          if Found then
          begin
            Result := Copy(Result, 1, P - 1) + Param.Value + Copy(Result,
              P + Length(Param.Name) + 1, MaxInt);
          end;
        end;
      until not Found;
    end;
  end;

var
  I: Integer;
begin
  for I := 0 to FSQL.Count - 1 do
    ToSQL.Add(ReplaceString(FSQL[I]));
end;


procedure TTntADOQuery.Loaded;
begin
  inherited;
  GetMacros; // Reload macros
end;

procedure TTntADOQuery.OpenCursor(InfoQuery: Boolean);
begin
  ExpandMacros;
  inherited OpenCursor(InfoQuery);
end;

constructor TTntADOStoredProc.Create(AOwner: TComponent);
begin
  inherited Create(AOwner);
  Command.CommandType := cmdStoredProc;
  TAccessADOCommand(Command).CommandTextAlias := 'ProcedureName'; { Do not localize }
end;

procedure TTntADOStoredProc.ExecProc;
begin
  InitializeMasterFields(Self);
  Command.Execute;
end;


function TTntADOQuery.GetCommandText: WideString;
begin
  Result := inherited CommandText;
end;



end.