wwtable.pas

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

unit Wwtable;
{
//
// Components : TwwTable
//
// Copyright (c) 1995-2001 by Woll2Woll Software
//
// 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.
// 3/5/98 - Call UpdateIndexes if indexdefs.count=0 or if its is still
//          initialized to indexdef component name.
//
// 11/7/98 - Don't load masks in design mode if active is false.  This can
//           end up re-opening the table when the form is closed.
// 11/17/1998 - Workaround Delphi 4 change in implementaion in SetData on BCD fields
// 4/13/99 - SetData may raise exception if data is unassigned
}
interface

{$i wwIfDef}

uses
  SysUtils, Windows, Messages, Classes, Graphics, Controls,
  Forms, DB, DBTables, dialogs, wwfilter, wwStr, wwSystem, wwLocate, wwtypes,
{$IFDEF WIN32}
bde, DBCommonTypes
{$ELSE}
dbiprocs, dbiTypes, dbierrs
{$ENDIF}
;

{$IFDEF VER110}
{$ObjExportAll On}
{$ENDIF}

type
  PtrBoolean = ^Boolean;
  TwwTableDisplayType = TStrings;

  TwwTable = class;
  TwwTableFilterEvent = Procedure(table: TwwTable; var accept: boolean) of object;
  

  TwwTable = class(TTable)
  private
     FFilter : TStrings;
     FQuery: TStrings;
     FPictureMasks: TStrings;
     FLookupFields: TwwTableDisplayType;
     FLookupLinks: TwwTableDisplayType;
     FControlType: TwwTableDisplayType;
     FUsePictureMask: boolean;

     FSyncSQLByRange: boolean;
     FNarrowSearch: boolean;
     FOnInvalidValue: TwwInvalidValueEvent;
     FOnFilterOptions: TwwOnFilterOptions;
     FOnFilterEscape: TDataSetNotifyEvent;
     FOnFilter: TwwTableFilterEvent;
     FFilterBuffer: Pointer;
     FFilterFieldBuffer: PChar;
     hFilter, hFilterFunction: hDBIFilter;
     FFilterParam: TParam;
     FIsSequencable: boolean;
     FNarrowSearchUpperChar: word;

{     QueryFileName: string;}
     QueryType: String;

     FOnDestroy: TNotifyEvent;

     dependentPtrs: TList;
     rangeFilter: hDBIFilter;
     isOpen: boolean;

     PdxMasks: TStrings;
     InitPdxMasks: boolean;
     CallCount: integer;

     function getLookupFields: TStrings;
     procedure setLookupFields(sel : TStrings);
     function getPictureMasks: TStrings;
     procedure setPictureMasks(sel : TStrings);

     function getLookupLinks: TStrings;
     procedure setLookupLinks(sel : TStrings);
     function getControlType: TStrings;
     procedure setControlType(sel : TStrings);
     procedure setFilterArray(sel: TStrings);
     Function getFilter: TStrings;
     procedure SetOnFilter(val: TwwTableFilterEvent);
     Function GetFilterCount: Longint;
     Procedure SetQuery(sel: TStrings);
     Function isSequencableTable: boolean;
     procedure SetTableName(const Value: TFileName);
     function GetTableName: TFileName;
     procedure DoInitPdxMasks;
     Function FindFieldsToIndex(AIndexFields: string;
         CaseSensitive, exactFieldMatch: boolean;
         var newIndexName: string): boolean;
     Procedure SetOnFilterOptions(val: TwwOnFilterOptions);

  protected
     procedure PrepareCursor; override;
     {$ifdef wwDelphi3Up}
     procedure OpenCursor(InfoQuery: Boolean); override;
     {$else}
     procedure OpenCursor; override;
     {$endif}
     procedure CloseCursor; override;
     Function CreateHandle:  HDBICur; override;
     Function PerformQuery(var AdbiHandle: HDBICur): DBIResult;
     procedure DoBeforePost; override; { For picture support }
     procedure InitFieldDefs; override;
     procedure DoOnCalcFields; override;  { Also promote to public }
     Function GetIndexFieldName: string;
     Procedure SetIndexFieldName(val: string);
{$ifdef wwDelphi3Up}
     procedure DataEvent(Event: TDataEvent; Info: Longint); override;
     function GetNextRecords: Integer; override;
     Procedure ResetMouseCursor;
{$endif}

  public
    UpToDate: boolean;         {Woll2Woll Internal only used if its a calculated field lookup link table }
    UpToDateRes: boolean;      {Woll2Woll Internal only used if its a calculated field lookup link table }
    CalcLookupLinks: String;   {Woll2Woll Internal only used if its a calculated field lookup link table }
    wwInternalPtr: Pointer;    {Woll2Woll Internal use only}
    inFilterEvent: boolean;    {Woll2Woll Internal use only}
    InLookupLink: boolean;     {Woll2Woll Internal use only}
    InFindRecordCount: integer; {Woll2Woll Internal use only}
    IgnoreMasterLink: boolean;  {Woll2Woll Internal use only}
    lookupTables: TList;       { List of lookup tables }

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

    property IsSequencable : boolean read FisSequencable;
    property FilterCount: Longint read GetFilterCount;

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

    Function IsValidField(fieldName : string): boolean;
    procedure RemoveObsoleteLinks;

    Function SetToIndexContainingFields(selected: TStrings): boolean;
    Function SetToIndexContainingField(selected: string): boolean;
    procedure SyncSQLTable(lookupTable: TTable);
    Procedure FreeLookupTables;
    Function wwFindNearest(key: string; FieldNo: integer): boolean;
    function wwFindKey(const KeyValues: array of Const): Boolean;
    function wwFindRecord(
       KeyValue: string;
       LookupField: string;
       MatchType: TwwLocateMatchType;
       CaseSensitive: boolean): boolean;

    procedure wwChangeIndex(a_indexItem: TIndexDef);
    procedure wwChangeIndexName(a_indexName: string);
    procedure AddDependentTablePtr(a_value: PtrBoolean);
    procedure RemoveDependentTablePtr(a_value: PtrBoolean);
    procedure wwSetRangeStart(const startValues: Array of Const);

    Function Pack(var statusMsg: string): boolean;

    Function setFilter(sel: string): boolean;
    Function FilterString: string;
    Function IsParadoxTable: boolean;
    Function IsDBaseTable: boolean;
    Function FilterActivate: boolean;
    Function wwFilterField(AFieldName: string): TParam;
    Function IndexToFields(aIndexName: string): string; { Convert index name to index fields}
    Function FieldsToIndex(aIndexFields: string): string;
    Function FieldstoIndexWithCase(aIndexFields: string; caseSensitive: boolean): string;
    Function GetDBPicture(curFieldName: string): string;
    Procedure UpdateIndexes;
    procedure FastCancelRange;
    procedure ClearCurrentRangeBuffers; { Call this before changing indexes on a detail table }
    function SetLookupField(Field: TField): boolean;
    {$ifdef wwDelphi3Up}
    function isCaseInsensitiveIndex: boolean;
    {$endif}
    procedure LoadPdxMasks;  { 4/18/98 - Provide way to reload masks }

    property OnDestroy: TNotifyEvent read FOnDestroy write FOnDestroy; {Woll2Woll Internal use only}
    property IndexFieldName: string read GetIndexFieldName write SetIndexFieldName;

  published
    property LookupFields : TStrings read getLookupFields write setLookupFields stored True;
    property LookupLinks : TStrings read getLookupLinks write setLookupLinks stored True;
    property ControlType : TStrings read getControlType write setControltype stored True;
    property PictureMasks: TStrings read GetPictureMasks write SetPictureMasks;

    property wwFilter : TStrings read getFilter write setFilterArray;
    property SyncSQLByRange: boolean read FSyncSQLByRange write FSyncSQLByRange;
    property NarrowSearch: boolean read FNarrowSearch write FNarrowSearch;
    property NarrowSearchUpperChar: word read FNarrowSearchUpperChar write FNarrowSearchUpperChar default 255;

    property Query: TStrings read FQuery write SetQuery;
    property TableName read GetTableName write SetTableName;
    property ValidateWithMask: boolean read FUsePictureMask write FUsePictureMask;
    property OnInvalidValue: TwwInvalidValueEvent read FOnInvalidValue write FOnInvalidValue;

    property OnFilter: TwwTableFilterEvent read FOnFilter write SetOnFilter;
    property OnFilterEscape: TDataSetNotifyEvent read FOnFilterEscape write FOnFilterEscape;
    property OnFilterOptions: TwwOnFilterOptions read FOnFilterOptions write SetOnFilterOptions
       default [ofoEnabled, ofoShowHourGlass];
  end;

  { Memo stream to support retrieving of records even during insert mode }
  {$ifndef wwDelphi3Up}
  TwwMemoStream = class(TStream)
  private
    FField: TBlobField;
    FDataSet: TDataSet;
    FRecord: PChar;
    FBuffer: PChar;
    FFieldNo: Integer;
    FOpened: Boolean;
    FPosition: Longint;
    function GetBlobSize: Longint;
    procedure CreateCommon(Field: TBlobField; InFilter: boolean);
  public
    constructor Create(Field: TBlobField);
    constructor CreateInFilter(Field: TBlobField; dummy: integer);
    destructor Destroy; override;
    function Read(var Buffer; Count: Longint): Longint; override;
    function Seek(Offset: Longint; Origin: Word): Longint; override;
    {$ifdef win32}
    function Write(const Buffer; Count: Longint): Longint; override;
    {$endif}
  end;
  {$endif}

procedure Register;

implementation

  uses wwcommon, dbconsts, wwdatsrc, wwpict,
{$ifdef wwDelphi6Up}
fmtbcd,
{$endif}
 wwintl;
  const UNKNOWN = '?';

    constructor TwwTable.create(AOwner: TComponent);
//    var TempParams: TParams;
    begin
      inherited Create(AOwner);

      FLookupFields:= TStringList.create;  { Must be a TStringList type }
      FLookupLinks:= TStringList.create;
      FControlType:= TStringList.create;
      FFilter:= TStringList.create;
      FQuery:= TStringList.create;
      FPictureMasks:= TStringList.create;
      lookupTables:= TList.create;       { List of lookup tables }
      dependentPtrs:= TList.create;
      CalcLookupLinks:= '';
      FSyncSQLByRange:= False;
      FNarrowSearch:= False;

//      {$ifdef wwDelphi4Up}
//      TempParams := TParams.Create(self);
//      {$else}
//      TempParams := nil;
//      {$endif}
      FFilterParam:= TParam.create(nil, ptUnknown);

      wwInternalPtr:= Nil;
      PdxMasks:= TStringlist.create;

      rangeFilter:= Nil;
      FUsePictureMask:= True;
      InitPdxMasks:= True;
      NarrowSearchUpperChar:= 255;
      FOnFilterOptions:= [ofoEnabled, ofoShowHourGlass];
    end;

    destructor TwwTable.Destroy;
    var i: integer;
        valPtr: PtrBoolean;
    begin
      FreeLookupTables;

      FLookupFields.Free;
      FLookupLinks.Free;
      FControlType.Free;
      FFilter.Free;
      FQuery.Free;
      FQuery:= Nil;
      FPictureMasks.Free;
      FPictureMasks:= Nil;
      PdxMasks.Free;

      lookupTables.free;
      lookupTables:= Nil;

      for i:= 0 to dependentPtrs.count-1 do
      begin
         valPtr:= DependentPtrs.items[i];
         valPtr^:= True;
      end;

      dependentPtrs.Free;
      dependentPtrs:=Nil;

      if FFilterFieldBuffer<>Nil then
         FreeMem(FFilterFieldBuffer, wwFilterMemoSize);
      FFilterParam.Free;
      if Assigned(FOnDestroy) then FOnDestroy(self);
      inherited Destroy;
    end;

    Function TwwTable.isDBaseTable: boolean;
    begin
      Result := (TableType = ttDBase) or
        (CompareText(ExtractFileExt(TableName), '.DBF') = 0);
    end;

Function TwwTable.GetFilterCount: Longint;
var count: Longint;
    FilterCountProc  : Function (hcursor: hDBICur; var iRecCount: Longint): DBIResult;
    hIdapi: THandle;
begin
   if (TableType > ttASCII) then result:= RecordCount { 3rd party engine }
   else begin
      {$ifdef win32}
      result:= RecordCount;
      exit;
      {$endif}
      hIdapi := GetModuleHandle('IDAPI01');
      @FilterCountProc:=GetProcAddress(hIdapi, 'dbiGetExactRecordCount');
      FilterCountProc(Handle, count);
      result:= count;
   end
end;

function filterFunction(
      ulClientData  : Longint;
      pRecBuf       : Pointer;
      iPhyRecNum    : Longint
 ): Integer; export;
{$IFDEF WIN32}
 stdcall;  {stdcall added for win95}
{$ENDIF}
var filteredTable: TwwTable;
    TempResult: boolean;
begin
   filteredTable:= TwwTable(ulClientData);
   if (csDestroying in filteredTable.ComponentState) then begin
      result:= 1;
      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
      else result:= 1
   end
end;

    procedure TwwTable.SetOnFilter(val: TwwTableFilterEvent);
    begin
       FOnFilter:= val;
       if @val=Nil then wwSetFilterFunction(Nil, self, hFilterFunction)
       else wwSetFilterFunction(@filterFunction, self, hFilterFunction);
    end;

    Function TwwTable.IsParadoxTable: boolean;
    var temptableName: string;
    begin
       if TableType = ttDefault then begin
          tempTableName:= tablename;
          tempTableName:= lowercase(tempTablename);
          result := (pos('.db', tempTableName)>0) and
                       (tempTableName[length(tempTableName)]='b');
       end
       else begin
          result:= TableType = ttParadox;
       end;
    end;

    Function TwwTable.IsSequencableTable: boolean;
    begin
       result:= False;
       if Handle=Nil then exit;
       if isParadoxTable then begin
          result:= True;
          exit;
       end;
{       result:= (not isDBASETable) and (TableType <= ttASCII) and
                (dbiGetSeqNo(Handle, temp)=0);                    }
       result:= False;
    end;

    Function TwwTable.Pack(var statusMsg: string): boolean;
    var
       rslt: DBIResult;
       szErrMsg: DBIMSG;
       pTblDesc: pCRTblDesc;
       bExclusive: Boolean;
       bActive: Boolean;
       isParadox, isdBASE: boolean;
       tempTableName: string;
       props: CurProps;  { Preserve password }
    begin
       Result:= False;
       StatusMsg:= '';

       if TableType = ttDefault then begin
          tempTableName:= tablename;
          tempTableName:= lowercase(tempTablename);
          isParadox := (pos('.db', tempTableName)>0) and
                       (tempTableName[length(tempTableName)]='b');
          isDBASE:= pos('.dbf', temptableName)>0;
       end
       else begin
          isParadox:= TableType = ttParadox;
          isDBASE:= TableType = ttDBASE;
       end;

       if isParadox or isdBASE then begin
          bExclusive:= Exclusive;
          bActive:= Active;
          DisableControls;
          Close;
          Exclusive:= True;
       end
       else begin
          StatusMsg:= 'Invalid table type for packing.';
          exit;
       end;

       if isParadox then begin
          if wwMemAvail(Sizeof(CRTblDesc)) then begin
             StatusMsg:=  'Cannot pack table.  Insufficient memory. ';
          end
          else begin
             GetMem(pTblDesc, SizeOf(CRTblDesc));
             FillChar(pTblDesc^, SizeOf(CRTblDesc), 0);
             with pTblDesc^ do begin
                strPCopy(szTblName, Tablename);
                strPCopy(szTblType, szParadox);

                { Check if table is password protected }
                active:= True;
                check(dbiGetCursorProps(Handle, props));
                bProtected:= props.bProtected;
                active:= False;

                bPack:= True;
             end;
             Screen.cursor:= crHourGlass;

             SetDBFlag(dbfOpened, True);
             rslt:= dbiDoRestructure(DBHandle, 1, pTblDesc, nil, nil, nil, False);
             if rslt <> DBIERR_NONE then begin
                dbiGetErrorString(rslt, szErrMsg);
                statusMsg:= szErrMsg;
             end
             else result:= True;
             SetDBFlag(dbfOpened, False);
             FreeMem(pTblDesc, SizeOf(CRTblDesc) );

             Screen.cursor:= crDefault;

          end
       end
       else if isdBASE then begin
          Screen.cursor:= crHourGlass;
          Open;
          rslt:= dbiPackTable(DBHandle, Handle, nil, nil, True);
          Screen.cursor:= crDefault;

          if rslt <> DBIERR_NONE then begin
             dbiGetErrorString(rslt, szErrMsg);
             statusMsg:= szErrMsg;
          end