tntdbutils.pas

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

unit TntDBUtils;

interface

{$I TntCompilers.inc}

uses
  SysUtils, Classes, DB, TntSysUtils;

type
  TLocateRec = record
    DB: TDataset;
    FieldName: string;
    Field: TField;
    Bookmark: TBookmarkStr;
    Value: WideString;
    CaseSensitive: Boolean;
  end;

function WildcardLocate(DB: TDataSet; const FieldName: string; const Expr: WideString;
  var LocateRec: TLocateRec; CaseSensitive: Boolean = False): Boolean;
function WildcardLocateNext(var LocateRec: TLocateRec): Boolean;
function WideWildcardMatchEx(const Source, Pattern: WideString; const ic: Boolean = True):
  Boolean;
procedure FreeLocateRec(var LocateRec: TLocateRec);
function WideDataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
  const KeyValues: Variant; Options: TLocateOptions): Boolean;

implementation

uses
  TntDB{$IFNDEF COMPILER_10_UP},TntWideStrUtils{$ENDIF}
  {$IFDEF COMPILER_6_UP}, Variants{$ENDIF};

function WideWildcardMatch(const source, pattern: WideString): Boolean;
var
  pSource: PWideChar;
  pPattern: PWideChar;

  function MatchPattern(element, pattern: PWideChar): Boolean;

    function IsPatternWild(pattern: PWideChar): Boolean;
    begin
     {$IFDEF COMPILER_10_UP}
      Result := StrScanW(pattern, '*') <> nil;
      if not Result then Result := StrScanW(pattern, '?') <> nil;
     {$ELSE}
      Result := WStrScan(pattern, '*') <> nil;
      if not Result then Result := WStrScan(pattern, '?') <> nil;
     {$ENDIF}
    end;

  begin
   {$IFDEF COMPILER_10_UP}
    if 0 = StrCompW(pattern, '*') then
   {$ELSE}
    if 0 = WStrComp(pattern, '*') then
   {$ENDIF}
      Result := True
    else if (element^ = #0) and (pattern^ <> #0) then
      Result := False
    else if element^ = #0 then
      Result := True
    else begin
      case pattern^ of
        '*': if MatchPattern(element, @pattern[1]) then
            Result := True
          else
            Result := MatchPattern(@element[1], pattern);
        '?': Result := MatchPattern(@element[1], @pattern[1]);
      else
        if element^ = pattern^ then
          Result := MatchPattern(@element[1], @pattern[1])
        else
          Result := False;
      end;
    end;
  end;

begin
 {$IFDEF COMPILER_9_UP}
  pSource := StrNewW(PWideChar(source));
  pPattern := StrNewW(pWideChar(pattern));
  try
    Result := MatchPattern(pSource, pPattern);
  finally
    StrDisposeW(pSource);
    StrDisposeW(pPattern);
  end;
 {$ELSE}
  pSource := WStrNew(PWideChar(source));
  pPattern := WStrNew(pWideChar(pattern));
  try
    Result := MatchPattern(pSource, pPattern);
  finally
    WStrDispose(pSource);
    WStrDispose(pPattern);
  end;
 {$ENDIF}
end;

function WideWildcardMatchIC(const source, pattern: WideString): Boolean;
begin
  { perform a case insensitive wildcard match by converting the pattern
    and source strings to uppercase. }
  result := WideWildcardMatch(Tnt_WideUpperCase(source), Tnt_WideUpperCase(pattern));
end;

function WideWildcardMatchEx(const Source, Pattern: WideString; const ic: Boolean = True):
  Boolean;
begin
  { perform a wildcard match, either case-sensitive or case-insensitive,
    depending on the ic flag. }
  if ic = True then
    result := WideWildcardMatchIC(source, pattern)
  else
    result := WideWildcardMatch(source, pattern);
end;


function WildcardLocate(DB: TDataSet; const FieldName: string;
  const Expr: WideString; var LocateRec: TLocateRec; CaseSensitive: Boolean = False): Boolean;
begin
  LocateRec.DB := DB;
  LocateRec.FieldName := FieldName;
  LocateRec.Field := DB.FieldByname(FieldName);
  LocateRec.Value := Expr;
  LocateRec.Bookmark := '';
  LocateRec.CaseSensitive := CaseSensitive;
  Result := WildcardLocateNext(LocateRec);
  if not Result then
    FreeLocateRec(LocateRec);
end;

function WildcardLocateNext(var LocateRec: TLocateRec): Boolean;
var
  OldPos: TBookmarkStr;
  Found: Boolean;
begin
  Result := False;
  with LocateRec do
  begin
    DB.DisableControls;
    OldPos := DB.Bookmark;
    try
      if LocateRec.Bookmark <> '' then
      begin
        DB.Bookmark := LocateRec.Bookmark;
        DB.Next;
      end
      else
        DB.First;
      while not DB.EOF do
      begin
        if CaseSensitive then
          Found := WideWildcardMatch(GetAsWideString(Field), LocateRec.Value)
        else
          Found := WideWildcardMatchIC(GetAsWideString(Field), LocateRec.Value);
        if Found then
        begin
          LocateRec.Bookmark := DB.Bookmark;
          Result := True;
          Exit;
        end
        else
          DB.Next;
      end;
    finally
      if not Result then
        DB.Bookmark := OldPos;
      DB.EnableControls;
    end;
  end;
end;

procedure FreeLocateRec(var LocateRec: TLocateRec);
begin
  LocateRec.Bookmark := '';
  LocateRec.Value := '';
  LocateRec.DB := nil;
end;

function WideDataSetLocateThrough(DataSet: TDataSet; const KeyFields: string;
  const KeyValues: Variant; Options: TLocateOptions): Boolean;
var
  FieldCount: Integer;
  Fields: TList;
  Bookmark: TBookmarkStr;

  function CompareField(Field: TField; Value: Variant): Boolean;
  var
    S: string;
    W: WideString;
  begin
    if (Field.DataType = ftString) or (Field.DataType = ftWideString) then
    begin
      if Value = Null then
        Result := Field.IsNull
      else
      begin
        if (Field.DataType = ftString) then
        begin
          S := Field.AsString;
          if loPartialKey in Options then
            Delete(S, Length(Value) + 1, MaxInt);
          if loCaseInsensitive in Options then
            Result := AnsiCompareText(S, Value) = 0
          else
            Result := AnsiCompareStr(S, Value) = 0;
        end else
        begin
          W := GetAsWideString(Field);
          if loPartialKey in Options then
            Delete(W, Length(Value) + 1, MaxInt);
          if loCaseInsensitive in Options then
            Result := WideCompareText(W, Value) = 0
          else
            Result := WideCompareStr(W, Value) = 0;
        end;
      end;
    end
    else
      Result := (Field.Value = Value);
  end;

  function CompareRecord: Boolean;
  var
    I: Integer;
  begin
    if FieldCount = 1 then
      Result := CompareField(TField(Fields.First), KeyValues)
    else
    begin
      Result := True;
      for I := 0 to FieldCount - 1 do
        Result := Result and CompareField(TField(Fields[I]), KeyValues[I]);
    end;
  end;

begin
  Result := False;
  with DataSet do
  begin
    CheckBrowseMode;
    if Bof and Eof then
      Exit;
  end;
  Fields := TList.Create;
  try
    DataSet.GetFieldList(Fields, KeyFields);
    FieldCount := Fields.Count;
    Result := CompareRecord;
    if Result then
      Exit;
    DataSet.DisableControls;
    try
      Bookmark := DataSet.Bookmark;
      try
        with DataSet do
        begin
          First;
          while not EOF do
          begin
            Result := CompareRecord;
            if Result then
              Break;
            Next;
          end;
        end;
      finally
        if not Result and DataSet.BookmarkValid(PChar(Bookmark)) then
          DataSet.Bookmark := Bookmark;
      end;
    finally
      DataSet.EnableControls;
    end;
  finally
    Fields.Free;
  end;
end;


end.