wwtable.pas

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

begin
   CreateCommon(Field, False);
end;

constructor TwwMemoStream.CreateInFilter(Field: TBlobField; dummy: integer);
begin
   CreateCommon(Field, True);
end;

destructor TwwMemoStream.Destroy;
begin
  if FOpened then
  begin
     DbiFreeBlob(FDataSet.Handle, FRecord, FFieldNo);
  end;
  if FBuffer <> nil then FreeMem(FBuffer, FDataSet.RecordSize);
end;

function TwwMemoStream.Read(var Buffer; Count: Longint): Longint;
var
  Status: DBIResult;
  N: Word;
  L: Longint;
  P: Pointer;
begin
  Result := 0;
  if FOpened then
  begin
    P := @Buffer;
    while Count > 0 do
    begin
      if Count > $8000 then N := $8000
      else N := Count;

      Status := DbiGetBlob(FDataSet.Handle, FRecord, FFieldNo, FPosition,
        N, P, L);
      case Status of
        DBIERR_NONE, DBIERR_ENDOFBLOB:
          begin
            if (FField is TMemoField) and (FField as TMemoField).Transliterate then
              NativeToAnsiBuf(FDataSet.Locale, P, P, L);
            Inc(FPosition, L);
            Inc(Result, L);
          end;
        DBIERR_INVALIDBLOBOFFSET:
          {Nothing};
      else
        DbiError(Status);
      end;
      if Status <> DBIERR_NONE then Break;
      Dec(Count, N);
      Inc(LongInt(P), N);

    end;
  end;
end;

{$ifdef win32}
function TwwMemoStream.Write(const Buffer; Count: Longint): Longint;
begin
   result:= 0;
end;
{$endif}

function TwwMemoStream.Seek(Offset: Longint; Origin: Word): Longint;
begin
  case Origin of
    0: FPosition := Offset;
    1: Inc(FPosition, Offset);
    2: FPosition := GetBlobSize + Offset;
  end;
  Result := FPosition;
end;

function TwwMemoStream.GetBlobSize: Longint;
begin
  Result := 0;
  if FOpened then
    Check(DbiGetBlobSize(FDataSet.Handle, FRecord, FFieldNo, Result));
end;

{$endif}

procedure TwwTable.wwSetRangeStart(const startValues: Array of Const);
begin
   CheckBrowseMode;
   SetKeyFields(kiRangeStart, StartValues);
   SetRangeEnd;   { Clears ending range buffer }
   ApplyRange;
end;

Function TwwTable.wwFilterField(AFieldName: string): TParam;
var curField: TField;
    isBlank: bool;
    OtherField: TField;
    method: TMethod;
    {$ifdef wwDelphi4Up}
    tempValue: Currency;
    {$endif}
begin
   curField:= findField(AFieldName);
   if curField=Nil then begin
     {$ifdef wwDelphi3Up}
      DatabaseErrorFmt(SFieldNotFound, [AFieldName, AFieldName]);
     {$else}
      DBErrorFmt(SFieldNotFound, [AFieldName]);
     {$endif}
      result:= FFilterParam;
      exit;
   end;

   if FFilterFieldBuffer=Nil then GetMem(FFilterFieldBuffer, wwFilterMemoSize); {11/3/97 }
   Integer(Pointer(FFilterFieldBuffer)^):= 0; { Clear field buffer } {10/15/96 - Workaround for 32 bit BDE bug}

   if (curfield is TMemoField) or (curfield.datatype=ftMemo) or
      (curfield.datatype = ftblob) then
   begin
     wwCallbackMemoRead(self, FFilterBuffer, FFilterFieldBuffer^, curField, wwFilterMemoSize);
     with FFilterParam do begin
        DataType:= ftString;  { 6/12/98 }
        SetData(FFilterFieldBuffer);
     end;
   end
   else if not wwisNonPhysicalField(curfield) then begin
     dbiGetField(handle, curField.FieldNo, FFilterBuffer, FFilterFieldBuffer, isBlank);

     with FFilterParam do begin
        DataType:= curField.DataType;
        if (DataType=ftString) and TStringField(curField).transliterate then
        { 11/06/1997 - Changed From database.locale to the dataset's locale.
                       May be able to optimize and just use string length. }
           NativeToAnsiBuf(Locale,FFilterFieldBuffer,FFilterFieldBuffer,255);

       {$ifdef win32}
        if (DataType=ftAutoInc) then DataType:=ftInteger;
       {$endif}

        {11/17/1998 - Workaround Delphi 4 change in implementaion in SetData on BCD fields}
        {$ifdef wwDelphi4Up}
        if Datatype=ftBCD then
        begin
           {$ifdef wwDelphi5Up}
           if BCDToCurr(PBCD(FFilterFieldBuffer)^, tempValue) then
           {$else}
           if BCDToCurr(Pointer(FFilterFieldBuffer), tempValue) then
           {$endif}
             FFilterParam.AsBCD := tempValue
          else FFilterParam.AsBCD := 0;
        end
        else
        {$endif}

        if isBlank then Clear { 4/13/99 - SetData may raise exception if data is unassigned }
        else SetData(FFilterFieldBuffer);
     end;
   end
   else begin

      method.data:= self;
      method.code:= @TwwTable.wwFilterField;
      OtherField := wwDataSet_GetFilterLookupField(Self, curfield, method);

{      OtherField := wwDataSet_GetFilterLookupField(Self,curfield);}

      if OtherField <> nil then begin
        FFilterParam.DataType:= OtherField.DataType;
        wwConvertFieldToParam(OtherField,FFilterParam,FFilterFieldBuffer);
      end;

   end;

   result:= FFilterParam;
end;

Function TwwTable.IndexToFields(aIndexName: string): string;
var i: integer;
begin
   UpdateIndexes;

   result:= '';
   for i:= 0 to IndexDefs.count-1 do begin
      with IndexDefs do begin
         { 9/5/96 - In case table contains index named PrimaryKey }
         if (aIndexName = Items[i].Name) or
            ((aIndexName = '') and (Items[i].Name='PrimaryKey')) then
         begin
             result:= Items[i].Fields;
             break;
         end
      end
   end
end;

function TwwTable.FindFieldsToIndex(AIndexFields: string;
         CaseSensitive, exactFieldMatch: boolean;
         var newIndexName: string): boolean;
var i: integer;
begin
   result:= false;
   for i:= 0 to IndexDefs.count-1 do begin
      with IndexDefs do begin
          if (pos(uppercase(aIndexFields), uppercase(Items[i].fields))=1)
              and ((ixCaseInsensitive in Items[i].Options)=not caseSensitive) then
          begin
             if exactFieldMatch then
                if length(aIndexFields)<>length(Items[i].fields) then continue;

             { Don't accept index names containing other index field names (i.e. field codedesc, field code)}
             if (length(items[i].fields)>length(aIndexFields)) and
                (items[i].fields[length(aIndexFields)+1]<>';') then continue;
             result:= True;
             NewIndexName:= Items[i].name;
             exit;
          end
       end
   end;
end;

{$ifdef wwDelphi3Up}
function TwwTable.isCaseInsensitiveIndex: boolean;
var Fields: TList;
begin
   Fields := TList.Create;
   try
      result:= false;
      GetFieldList(Fields, IndexFieldName);
      result:= MapsToIndex(Fields, True);
   finally
      Fields.Free;
   end;
end;
{$endif}

Function TwwTable.FieldstoIndexWithCase(aIndexFields: string; caseSensitive: boolean): string;
begin
   result:= UNKNOWN;
   UpdateIndexes;

   if FindFieldsToIndex(AIndexFields, caseSensitive, True, result) then exit;
   if FindFieldsToIndex(AIndexFields, caseSensitive, False, result) then exit;
end;

{ Call FieldsToIndexWithCase method instead }
Function TwwTable.FieldstoIndex(aIndexFields: string): string;
begin
   result:= UNKNOWN;
   UpdateIndexes;

   if FindFieldsToIndex(AIndexFields, False, True, result) then exit;
   if FindFieldsToIndex(AIndexFields, True, True, result) then exit;

   if FindFieldsToIndex(AIndexFields, False, False, result) then exit;
   if FindFieldsToIndex(AIndexFields, True, False, result) then exit;
end;

Function TwwTable.PerformQuery(var AdbiHandle: HDBICur): DBIResult;
var hStmt: HDbiStmt;
    tempQBE: TStrings;
    QBEBuf: PChar;
begin
   AdbiHandle:= Nil;

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

   QBEBuf:= wwGetQueryText(tempQBE, queryType<>'QBE');

   {$ifdef win32}
   if QueryType='QBE' then
      Check(DbiQAlloc(DBHandle, qrylangQBE, hStmt))
   else
      Check(DbiQAlloc(DBHandle, qrylangSQL, hStmt));
   {$else}
   if QueryType='QBE' then begin
      result:= DbiQPrepare(DBHandle, qryLangQBE, QBEBuf, hStmt);
      if result<>DBIERR_NONE then exit;
   end
   else begin
      result:= DbiQPrepare(DBHandle, qryLangSQL, QBEBuf, hStmt);
      if result<>DBIERR_NONE then exit;
   end;
   {$endif}

   try
      if QueryType='QBE' then begin
         Check(dbiSetProp(hDBIObj(hStmt), stmtAUXTBLS, 0));
         Check(dbiSetProp(hDBIObj(hStmt), stmtBLANKS, 1));
      end
      else begin
      end;

   {$ifdef win32}
   result:= DbiQPrepare(hStmt, QBEBuf);
   if result<>DBIERR_NONE then exit;
   {$endif}

   Screen.cursor:= crHourGlass;
   result:= dbiQExec(hStmt, @ADBIHandle);
   if result<>DBIERR_NONE then exit;

   finally
      Check(DbiQFree(hStmt));
      tempQBE.Free;
      strDispose(QBEBuf);
      Screen.cursor:= crDefault;
      hStmt:= nil;
   end;

end;


procedure TwwTable.DoBeforePost;
begin
  inherited DoBeforePost;
  if FUsePictureMask then
     wwValidatePictureFields(self, FOnInvalidValue);
end;

procedure TwwTable.LoadPdxMasks;
begin
   InitPdxMasks:= True;
   DoInitPdxMasks;
end;

Procedure TwwTable.DoInitPdxMasks;
var
  VCursor: HDBICur;
  STableName: array[0..DBIMAXTBLNAMELEN - 1] of Char;
  ValCheckDesc: VCHKDesc;
  isActive: boolean;
  i: integer;
begin
   if not InitPdxMasks then exit;
   if not isParadoxTable then exit;
   if (not active) and (csAncestor in ComponentState) then exit; { 10/22/98 }
   if (not active) and (csDesigning in ComponentState) then exit; { 11/7/98 }

   InitPdxMasks:= False;

   { Table needs to be active for picture masks to be properly loaded }
   isActive:= Active;
   if not isActive then
     {$ifdef wwDelphi3Up}
      OpenCursor(False);
     {$else}
      OpenCursor;
     {$endif}


   AnsiToNative(DBLocale, TableName, STableName, SizeOf(STableName) - 1);

   PdxMasks.clear;
   if (DbiOpenVChkList(DBHandle, sTableName, 'PARADOX', VCursor)=0) then begin
      while DbiGetNextRecord(VCursor, dbiNoLock, @ValCheckDesc, nil) = 0 do begin
         for i:= 0 to FieldCount-1 do
            if Fields[i].FieldNo=ValCheckDesc.iFldNum then
            begin
               PdxMasks.add(Fields[i].FieldName + #9 + StrPas(ValCheckDesc.szPict));
               break;
            end
      end;
      DbiCloseCursor(VCursor);
   end;

   if not isActive then CloseCursor;

end;

Function TwwTable.GetDBPicture(curFieldName: string): string;
var
   curPos, i: integer;
   FieldName: string;
begin
   result:= '';
   if not isParadoxTable then exit;

   DoInitPdxMasks;

   for i:= 0 to PdxMasks.count-1 do begin
      curPos:= 1;
      FieldName:= strGetToken(PdxMasks[i], #9, curpos);
      if (curFieldName = FieldName) then
      begin
         result:= strGetToken(PdxMasks[i], #9, curPos);
         break;
      end
   end;
end;

Procedure TwwTable.RefreshLinks;
var i: integer;
begin
    for i:= 0 to LookupTables.count-1 do
       if TwwTable(LookupTables[i]).active then
          TwwTable(LookupTables[i]).refresh;
end;

Procedure TwwTable.UpdateIndexes;
begin
   if (IndexDefs.count=0) or
      ((IndexDefs.count>=1) and (IndexDefs.Items[0].Name = Name + 'Index0')) then
      IndexDefs.update;
end;

procedure TwwTable.InitFieldDefs;
begin
   if (Query.Count=0) or (Handle<>nil) then inherited InitFieldDefs
   else begin
      if not Active then try
        {$ifdef wwDelphi3Up}
         OpenCursor(True);
        {$else}
         OpenCursor;
        {$endif}
      finally
         CloseCursor;
      end;
   end
end;

Procedure TwwTable.SetIndexFieldName(val: string);
begin
   SetToIndexContainingField(val);
end;

Function TwwTable.GetIndexFieldName: string;
var indexFlds: string;
    curpos: integer;
begin
   curpos:= 1;
   indexFlds:= indexFieldNames;
   if indexFlds='' then indexFlds:= IndexToFields(indexName);
   if indexFlds='' then result:= ''
   else result:= strGetToken(indexFlds, ';', curpos);
end;

procedure TwwTable.FastCancelRange;
var selected: TStringList;
begin
   if wwInternational.FastSQLCancelRange and database.isSQLBased then
   begin
     selected:= TStringList.create;
     wwDataSetUpdateSelected(self, selected);
     active:= False;
     active:= True;
     wwDataSetUpdateFieldProperties(self, selected);
     selected.free;
   end
   else CancelRange
end;


Procedure TwwTable.SetOnFilterOptions(val: TwwOnFilterOptions);
begin
   if (ofoEnabled in FOnFilterOptions) and
      not (ofoEnabled in val) then
   begin
      FOnFilterOptions:= val;
      if active and Assigned(FOnFilter) then begin
         UpdateCursorPos;
         resync([]);
      end
   end
   else FOnFilterOptions:= val;
end;

procedure TwwTable.ClearCurrentRangeBuffers;
begin
   SetKeyBuffer(kiCurRangeStart, True);
   SetKeyBuffer(kiCurRangeend, True);
end;

function TwwTable.SetLookupField(Field: TField): boolean;
begin
   result:= wwSetLookupField(self, Field)
end;

{$ifdef wwDelphi3Up}
procedure TwwTable.ResetMouseCursor;
begin
   if (ofoShowHourGlass in OnFilterOptions) and ProcessingOnFilter then
   begin
      if Screen.cursor<>crArrow then
      begin
         Screen.cursor:= crArrow;
         ProcessingOnFilter:= False;
      end
   end
end;

function TwwTable.IsSequenced: Boolean;
begin
  result:= inherited isSequenced;
  if result then begin
     if Assigned(FOnFilter) then result:= False;
     if (FilterString<>'') then result:= False;
  end
end;

function TwwTable.GetNextRecords: Integer;
begin
   result:= inherited GetNextRecords;
   ResetMouseCursor;
end;

procedure TwwTable.DataEvent(Event: TDataEvent; Info: Longint);
begin
   inherited DataEvent(Event, Info);
   ResetMouseCursor;
end;

{$endif}

procedure Register;
begin
{  RegisterComponents('InfoPower', [TwwTable]);}
end;

end.