wwqbe.pas

胜天进销存源码,国产优秀的进销存

unit Wwqbe;
{
//
// Components : TwwQBE - Query by Example
//
// Copyright (c) 1995-2001 by Woll2Woll Software
//
// 6/8/95 - New property BlankAsZero
// 6/14/95 - Add method SetParam
// 11/06/1997 - Changed From database.locale to the dataset's locale.
//              May be able to optimize and just use string length.
//              To handle international character support while filtering.
// 11/17/1998 - Workaround Delphi 4 change in implementaion in SetData on BCD fields
// 12/28/98 - Don't replace original after calling AnsiToNative
// 4/13/99 - SetData may raise exception if data is unassigned
// 5/30/00 - Support error code
}
interface

{$i wwIfDef.pas}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, DB, DBTables, dialogs, wwfilter, wwStr,
  wwSystem, wwTable, wwtypes,

{$IFDEF WIN32}
bde
{$ELSE}
dbiprocs, dbiTypes, dbierrs
{$ENDIF}
;

type
  TwwQBE = class;
  TwwQBEFilterEvent = Procedure(Qbe: TwwQBE; var Accept: boolean) of object;
  TwwQBEErrorEvent = Procedure(Qbe: TwwQBE; ErrorCode: integer) of object;
  TwwQBE = class(TDBDataSet)
  private
     FLookupFields: TStrings;
     FLookupLinks: TStrings;
     FControlType: TStrings;
     FPictureMasks: TStrings;
     FQBE: TStrings;            { support Paradox style QBE }
     FAnswerTable: String;
     FAuxiliaryTables: Boolean;
     FBlankAsZero: boolean;
     FParamValues: TStrings;
     FOnError: TwwQBEErrorEvent;
     FParams: TStringList;
     bSkipCreateHandle, bUpdateQuery: boolean;
     TempHandle: HDBICur;

     FOnInvalidValue: TwwInvalidValueEvent;
     FOnFilterOptions: TwwOnFilterOptions;
     FOnFilterEscape: TDataSetNotifyEvent;
     FOnFilter: TwwQBEFilterEvent;
     FFilterBuffer: Pointer;
     FFilterFieldBuffer: PChar;
     hFilterFunction: hDBIFilter;
     FFilterParam: TParam;
     CallCount: integer;

     procedure SetOnFilter(val: TwwQBEFilterEvent);
     procedure SetQBE(QBE: TStrings);
     function GetLookupFields: TStrings;
     procedure SetLookupFields(sel : TStrings);
     function GetLookupLinks: TStrings;
     procedure SetLookupLinks(sel : TStrings);
     function getControlType: TStrings;
     procedure SetControlType(sel : TStrings);
     function GetPictureMasks: TStrings;
     procedure SetPictureMasks(sel : TStrings);
     Procedure SetOnFilterOptions(val: TwwOnFilterOptions);

  protected
     procedure DoOnCalcFields; override;
     function CreateHandle: HDBICur; override;
   {$ifdef wwDelphi3Up}
     procedure OpenCursor(InfoQuery: Boolean); override;
   {$else}
     procedure OpenCursor; override;
   {$endif}
     procedure DoAfterOpen; override;
     Function PerformQuery(var AdbiHandle: HDBICur): DBIResult; virtual;

     {$ifdef wwDelphi3Up}
     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
     function GetNextRecords: Integer; override;
     Procedure ResetMouseCursor;
     {$endif}


  public
    LookupTables: TList;       { List of lookup tables }
    inFilterEvent: boolean;    {Woll2Woll Internal use only}

    {$ifdef wwDelphi3Up}
    ProcessingOnFilter: boolean;
    function IsSequenced: Boolean; override;
    {$endif}

    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;
    Function IsValidField(fieldName : string): boolean;
    procedure RemoveObsoleteLinks;
    Procedure FreeLookupTables;
    Function SaveAnswerTable(tableName: string): boolean;
    Function wwFilterField(AFieldName: string): TParam;

    Procedure SetParam(paramName: string; paramValue: string);
    Procedure ClearParams;
    Function GetParam(paramName: string): string;

  published
    property ControlType : TStrings read getControlType write setControltype;
    property LookupFields : TStrings read getLookupFields write setLookupFields;
    property LookupLinks : TStrings read getLookupLinks write setLookupLinks;
    property QBE: TStrings read FQBE write SetQBE;
    property AnswerTable: String read FAnswerTable write FAnswerTable;
    property AuxiliaryTables: Boolean read FAuxiliaryTables write FAuxiliaryTables;
    property BlankAsZero: Boolean read FBlankAsZero write FBlankAsZero;
    property PictureMasks: TStrings read GetPictureMasks write SetPictureMasks;
    {$ifdef win32}
    property UpdateObject;
    {$endif}
    property OnFilter: TwwQBEFilterEvent read FOnFilter write SetOnFilter;
    property OnFilterEscape: TDataSetNotifyEvent read FOnFilterEscape write FOnFilterEscape;
    property OnFilterOptions: TwwOnFilterOptions read FOnFilterOptions write SetOnFilterOptions
       default [ofoEnabled, ofoShowHourGlass];
    property OnInvalidValue: TwwInvalidValueEvent read FOnInvalidValue write FOnInvalidValue;
    property OnError: TwwQBEErrorEvent read FOnError write FOnError;

  end;

procedure Register;

implementation

uses
   wwcommon,
   {$ifdef wwDelphi6Up}
   fmtbcd,
   {$endif}
   dbconsts;

function filterQBEFunction(
      ulClientData  : Longint;
      pRecBuf       : Pointer;
      iPhyRecNum    : Longint
 ): Integer; export;
{$IFDEF WIN32}
 stdcall;  {stdcall added for win95}
{$ENDIF}
var filteredTable: TwwQBE;
    TempResult: boolean;
begin
   result:= 1;

   filteredTable:= TwwQBE(ulClientData);
   if (csDestroying in filteredTable.ComponentState) then begin
      exit;
   end;

   with filteredTable do begin
      if Assigned(FOnFilter) then begin
         if (inFilterEvent or (not (ofoEnabled in OnFilterOptions))) then begin
            result:= 1;
            exit;
         end;

         inFilterEvent:= True;
         FFilterBuffer:= pRecBuf;
         TempResult:= True;
         OnFilter(filteredTable, tempResult);
         if TempResult then result:= 1 else result:= 0;
         inFilterEvent:= False;

         {$ifdef wwDelphi3Up}
         if ofoShowHourGlass in OnFilterOptions then
           if (not ProcessingOnFilter) and (Result=0) then
           begin
              if Screen.cursor<>crHourglass then
              begin
                 Screen.cursor:= crHourGlass;
              end;
              ProcessingOnFilter:= True;
           end;
         {$endif}

         { 10/24/96 - Yield so background tasks can run }
         if ofoCancelOnEscape in OnFilterOptions then
         begin
            inc(CallCount);
            if CallCount>=32000 then CallCount:= 0;
            if (CallCount mod 100)=0 then
               if wwProcessEscapeFilterEvent(filteredTable) then
               begin
                  OnFilterOptions:= OnFilterOptions - [ofoenabled];
                  if Assigned(FOnFilterEscape) then OnFilterEscape(filteredTable);
               end
         end;


      end
   end
end;

    constructor TwwQBE.Create(AOwner: TComponent);
    begin
      inherited Create(AOwner);
      FControlType:= TStringList.create;
      FLookupFields:= TStringList.create;  { Must be a TStringList type }
      FLookupLinks:= TStringList.create;
      FPictureMasks:= TStringList.create;
      FParams:= TStringList.create;
{      FParams.sorted:= True;}
      FParamValues:= TStringList.create;

      FAuxiliaryTables:= True;
      FBlankAsZero:= True;
      FAnswerTable:= '';

      lookupTables:= TList.create;       { List of lookup tables }
      FQBE := TStringList.Create;
      bSkipCreateHandle:= False;

      FFilterParam:= TParam.create(nil, ptUnknown);
      FOnFilterOptions:= [ofoEnabled, ofoShowHourGlass];
    end;

    destructor TwwQBE.Destroy;
    begin
      FLookupFields.Free;
      FLookupLinks.Free;
      FControlType.Free;
      FPictureMasks.Free;
      FPictureMasks:= Nil;
      LookupTables.free;
      FQBE.Free;
      FParams.Free;
      FParamValues.Free;

      if FFilterFieldBuffer<>Nil then
         FreeMem(FFilterFieldBuffer, wwFilterMemoSize);
      FFilterParam.Free;

      inherited Destroy;
    end;

   Procedure TwwQBE.ClearParams;
   begin
      FParamValues.clear;
      FParams.Clear;
   end;

   Function TwwQBE.GetParam(paramName: string): string;
   var idx: integer;
   begin
      Result:= '';
      idx:= FParams.indexOf(paramName);
      if idx>=0 then result:= FParamValues[idx];
   end;

   Procedure TwwQBE.SetParam(paramName: string; paramValue: string);
   var idx: integer;
   begin
      idx:= FParams.indexOf(paramName);
      if idx>=0 then
         FParamValues[idx]:= paramValue
      else begin
         FParams.add(paramName);
         FParamValues.add(paramValue);
      end
   end;

   procedure TwwQBE.SetQBE(QBE: TStrings);
   begin
     FQBE.Assign(QBE);
     if Active then begin
        Active:= False;
        Active:= True;
     end
   end;

    procedure TwwQBE.DoAfterOpen;
    begin
       inherited DoAfterOpen;
       if assigned(FOnFilter)then begin
          wwSetFilterFunction(@filterQBEFunction, self, hFilterFunction);
       end
    end;

   {Over-ride to support insert and update queries }
 {$ifdef wwDelphi3Up}
   procedure TwwQBE.OpenCursor(InfoQuery: Boolean);
 {$else}
    procedure TwwQBE.OpenCursor;
 {$endif}
   begin
      SetDBFlag(dbfOpened, True);
      TempHandle:= CreateHandle;
      if bUpdateQuery then exit;

      bSkipCreateHandle:= True;

    {$ifdef wwDelphi3Up}
      inherited OpenCursor(InfoQuery);
    {$else}
      inherited OpenCursor;
    {$endif}

      bSkipCreateHandle:= False;

   end;


    Function TwwQBE.PerformQuery(var AdbiHandle: HDBICur): DBIResult;
    const
        NativeStrLen=255;
    var hStmt: HDbiStmt;
        tempQBE: TStrings;
        QBEBuf: PChar;
        curpos, matchPos, i,j: integer;
        ParamLower, QBELower: string;
        NativeStr: PChar;
    begin
       AdbiHandle:= Nil;

       tempQBE:= TStringList.create;
       tempQBE.assign(FQBE);

       GetMem(NativeStr, NativeStrLen); { 4/25/97}

       for j:= 0 to FQBE.count-1 do begin
          QBELower:= lowercase(tempQBE[j]);
          if pos('~', QBELower)=0 then continue;

          for i:= FParams.count-1 downto 0 do begin { Scan backwards so line1 and line10 are handled}
             ParamLower:= lowercase(FParams[i]);

             {4/25/97 - Use AnsiToNative to support international characters }
             AnsiToNative(database.Locale, FParamValues[i], NativeStr, NativeStrLen);