locate.pas

产品信息系统!关于产品基础信息的系统!功能强大!

unit locate;
{
//
// Component : TwwLocateDialog
//
// Non-indexed searching
//
// Copyright (c) 1995-2001 by Woll2Woll Software
//
// 11/06/1997 - Changed UpperCase to AnsiUpperCase and OEMTOANSI to Dataset.Translate
//              to handle international character support.
//
// 11/10/97 - Do not call dbiGetNextRecord for memo field
// 12/12/97 - Changed MemoMatch to use String instead of BlobStream technique.
// 1/7/98 - Ensure non-null value when comparing floating field value from table
//
// 4/20/98 - Test eof after calling dataset.Next
//
// 1/21/01 - Add CloseOnMatch property to allow dialog to stay open
// 10/16/01- Support ftLargeInt.
// 10/25/2001 - Need to check EOF again. (PYW)
}

interface

{$i wwIfDef.pas}

uses
  SysUtils, WinTypes, WinProcs, Messages, Classes, Graphics, Controls,
  Forms, Dialogs, StdCtrls, Buttons, db, ExtCtrls,
  dbtables, dbctrls, {Wwdbcomb, }wwstr, wwDialog;

type

  TwwLocateMatchType = (mtExactMatch,  mtPartialMatchStart, mtPartialMatchAny);
  TwwFieldSortType = (fsSortByFieldNo, fsSortByFieldName);
  TwwDefaultButtonType = (dbFindFirst, dbFindNext);
  TwwFieldSelection = (fsAllFields, fsVisibleFields);
  TLocateDlg = class;
  TwwOnInitLocateDlgEvent = procedure(Dialog : TLocateDlg) of object;
  TwwLocateSelectFieldEvent = procedure(Dialog: TLocateDlg; SearchField: string) of object;
  TLocateDlgOption = (ldoCaseSensitiveBelow, ldoCloseOnMatch, ldoPreserveSearchText);
  TLocateDlgOptions = Set of TLocateDlgOption;

  TLocateDlg = class(TForm)
    SearchTypeGroup: TGroupBox;
    FieldsGroup: TGroupBox;
    CaseSensitiveCheckBox: TCheckBox;
    ExactMatchBtn: TRadioButton;
    PartialMatchStartBtn: TRadioButton;
    PartialMatchAnyBtn: TRadioButton;
    Panel1: TPanel;
    FieldValueGroup: TGroupBox;
    SearchValue: TEdit;
    FirstButton: TButton;
    NextButton: TButton;
    FieldNameComboBox: TComboBox;
    procedure FindFirst(Sender: TObject);
    procedure FindNextBtnClick(Sender: TObject);
    procedure BitBtn1KeyUp(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FieldNameComboBoxChange(Sender: TObject);
    procedure FieldNameComboBoxEnter(Sender: TObject);
    procedure FieldNameComboBoxExit(Sender: TObject);
    procedure FieldNameComboBoxKeyDown(Sender: TObject; var Key: Word;
      Shift: TShiftState);
    procedure FormShow(Sender: TObject);
    procedure FormCreate(Sender: TObject);

  private
    Function GetFieldNameFromTitle(fieldTitle: string): string;
    procedure ApplyIntl;

  public
    DataSet: TDataSet;
    CancelBtn: TButton;
    DlgComponent: TComponent;
    Function FindMatch(FromBeginning: boolean): boolean;
    constructor Create(AOwner: TComponent); override;
  end;

TLocateDlg = class(TwwCustomDialog)
  private
     FCaption: String;
     FDataField: String;
     FDataLink: TDataLink;
     FFieldValue: string;
     FMatchType: TwwLocatematchType;
     FCaseSensitive: boolean;
     FSortFields: TwwFieldSortType;
     FDefaultButton: TwwDefaultButtonType;
     FFieldSelection: TwwFieldSelection;
     FShowMessages: boolean;
     FOptions: TLocateDlgOptions;
//     FCloseOnMatch: boolean;
     FOnInitDialog: TwwOnInitLocateDlgEvent;
     FOnSelectField: TwwLocateSelectFieldEvent;
     FUseLocateMethod: boolean;
//     FUseLocateMethod: boolean;

     procedure SetDataSource(value : TDataSource);
     Function GetDataSource: TDataSource;

  protected
     procedure DoInitDialog; virtual;  { called by locate dialog form }
  public
     Form: TLocateDlg;  {Used by TwwLocateDlg }
     Patch: Variant;

     function GetPrimaryDataSet: TDataSet; override;

     constructor Create(AOwner: TComponent); override;
     destructor Destroy; override;

     function Execute: boolean; override;  { shows dialog }
     function FindPrior: boolean;
     function FindNext: boolean;
     function FindFirst: boolean;
     property FieldValue: string read FFieldValue write FFieldValue;
  published
     property Caption: string read FCaption write FCaption;
     property DataSource: TDataSource read GetDataSource write SetDataSource;
     property SearchField: String read FDataField write FDataField;
     property MatchType: TwwLocateMatchType read FMatchType write FMatchType;
     property CaseSensitive: boolean read FCaseSensitive write FCaseSensitive;
     property SortFields: TwwFieldSortType read FSortFields write FSortFields;
     property DefaultButton: TwwDefaultButtonType read FDefaultButton write FDefaultButton;
     property FieldSelection: TwwFieldSelection read FFieldSelection write FFieldSelection;
     property ShowMessages: boolean read FShowMessages write FShowMessages;
     property UseLocateMethod: boolean read FUseLocateMethod write FUseLocateMethod default False;
     property Options : TLocateDlgOptions read FOptions write FOptions default [ldoCloseOnMatch];
//     property CloseOnMatch: boolean read FCloseOnMatch write FCloseOnMatch default True;
     property OnInitDialog: TwwOnInitLocateDlgEvent read FOnInitDialog write FOnInitDialog;
     property OnSelectField: TwwLocateSelectFieldEvent read FOnSelectField write FOnSelectField;
//     property UseLocateMethod: boolean read FUseLocateMethod write FUseLocateMethod;
 end;

Function wwFindMatch(FromBeginning: boolean;
	       DataSet: TDataSet;
	       searchField: string;
	       searchValue: string;
	       matchType: TwwLocateMatchType;
	       caseSens: boolean;
               UseLocateMethod: boolean = False): boolean;

var
  LocateDlg: TLocateDlg;

implementation

uses wwCommon, wwSystem, wwintl, wwtable,
(*
{$ifdef DELPHI3_CS}
wwclient,
{$endif}
*)

{$ifdef win32}
comctrls, bde;
{$else}
dbiprocs, dbierrs, dbitypes;
{$endif}

{$R *.DFM}

Function Match(val1: string; val2: string;
	       matchType: TwwLocateMatchType;
	       caseSens: boolean): boolean;
var matchPos: integer;
begin
   if not caseSens then val1:= AnsiUppercase(val1); {11/06/1997 - Changed to AnsiUppercase}

   if MatchType = mtExactMatch then begin
      if length(val1)<>length(val2) then result:= False
      else begin
	 if length(val1)=0 then result:= True
	 else begin
	    matchPos:= Pos(val2, val1);
	    result:= (matchPos=1);
	 end
      end
   end else if matchType = mtPartialMatchStart then
   begin
      matchPos:= Pos(val2, val1);
      result:= (matchPos=1);
   end
   else if MatchType = mtPartialMatchAny then
   begin
      matchPos:= Pos(val2, val1);
      result:= (matchPos<>0);
   end
   else result:= False;

end;

{ 12/12/97 - Changed MemoMatch to use String instead of BlobStream technique.}
{$ifdef wwDelphi3Up}
Function MemoMatch(field : TField;
	       memoBuffer: PChar; val1 :Pchar;
	       matchType: TwwLocateMatchType;
	       caseSens: boolean;
               RichEditControl: TRichEdit): boolean;
var matchPos: Integer;
    s: string;
begin
{   result:= False;}

   if RichEditControl<>Nil then
   begin
      RichEditControl.PlainText:= False;
      RichEditControl.Lines.Assign(Field);
      RichEditControl.PlainText:= True;
      s:= RichEditControl.Text;
   end
   else s:= field.asstring;

   if not caseSens then s := AnsiUpperCase(s);

   if MatchType = mtExactMatch then begin
      {$WARNINGS OFF}
      if strlen(val1)<>length(s) then result:= False
      {$WARNINGS ON}
      else begin
         matchPos:= AnsiPos(StrPas(val1),s);
         result:= (matchPos=1);
      end
   end
   else if matchType = mtPartialMatchStart then begin
       matchPos:= AnsiPos(StrPas(val1),s);
       result:= (matchPos=1);
   end
   else if MatchType = mtPartialMatchAny then begin
       matchPos:= AnsiPos(StrPas(val1),s);
       result:= (matchPos<>0);
   end
   else result:= False;
end;

{$else}
Function MemoMatch(field : TField;
	       memoBuffer: PChar; val1 :Pchar;
	       matchType: TwwLocateMatchType;
	       caseSens: boolean): boolean;
var matchPtr: PChar;
    numread: integer;
    blobStream: TBlobStream;
begin
   result:= False;
   blobStream:= Nil;
   try
      blobStream:= TBlobStream.create(TBlobField(field), bmRead);
      if blobStream=Nil then begin
	 MessageDlg('Fail to create blob', mtinformation, [mbok], 0);
	 exit;
      end;

      numread:= blobStream.read(memobuffer^, 32767);
      memobuffer[numread]:= #0; { null-terminate }

      if numread = 0 then strcopy(memobuffer, '');

      if not caseSens then
        StrUpper(memobuffer);

      if MatchType = mtExactMatch then begin
	 if strlen(val1)<>numread then result:= False
	else begin
	    matchPtr:= strPos(memobuffer, val1);
	    if matchPtr<>Nil then
	       result:= (matchPtr=memoBuffer);
	 end
      end else if matchType = mtPartialMatchStart then
      begin
	 matchPtr:= strPos(memobuffer, val1);
	 if matchPtr<>Nil then
	    result:= (matchPtr=memoBuffer);
      end
      else if MatchType = mtPartialMatchAny then
      begin
	 matchPtr:= strPos(memobuffer, val1);
	 result:= (matchPtr<>Nil);
      end
      else result:= False;
   finally
       blobStream.free;
   end;
end;

{$endif}

Function ValueAsString(field : TField; buffer: PChar) : string;
type
   WordPtr =^Word;
   IntegerPtr = ^Integer;
   LongPtr =^LongInt;
   FloatPtr = ^Double;
   Int64Ptr=^Int64;

   TDateTimeRec = record
     case TFieldType of
       ftDate: (Date: Longint);
       ftTime: (Time: Longint);
       ftDateTime: (DateTime: TDateTime);
   end;
   DateTimePtr = ^TDateTimeRec;

var
   DateTimeData: TDateTimeRec;
   floatValue: Double;

{$ifdef win32}
    TimeStamp: TTimeStamp;
{$endif}

{$ifndef wwDelphi3Up}
    Len:Integer;
{$endif}

begin
   result:= '';

   case field.DataType of
      ftString:
	 begin
	    if (field is TStringField) then
	       if TStringField(field).transliterate then
               begin
                  { 11/06/1997 - Added international character support.}
                  {$ifdef wwDelphi3Up}
                     Field.DataSet.Translate(Buffer,Buffer,False);
                  {$else}
                  Len := Strlen(Buffer);
                  NativeToAnsiBuf(Field.Dataset.Locale,Buffer,Buffer,Len);
                  {$endif}
               end;
	    result:= strPas(buffer);
	 end;

      ftSmallInt, ftWord: result:= inttostr(WordPtr(buffer)^);

      ftInteger: result:= inttostr(LongPtr(buffer)^);

      ftLargeInt: result := inttostr(Int64Ptr(Buffer)^);  //10/16/2001-Support ftLargeInt?

      {$ifdef win32}
      ftAutoInc: result:= inttostr(LongPtr(buffer)^);  { 12/2/96 - Support autoincrement field }
      {$endif}

      {$ifdef wwDelphi6Up}
      ftFMTBcd,
      {$endif}
      ftFloat, ftBCD, ftCurrency:
	 begin
	    floatValue:= FloatPtr(buffer)^;
	    result:= floattostr(floatValue);
	 end;

      ftBoolean: begin
		     if buffer[0]<>char(0) then result:= 'True'
		     else result:= 'False';
		 end;

      ftDateTime:  begin
	    DateTimeData:= DateTimePtr(buffer)^;