wwqbe.pas

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

             { 12/28/98 - Don't replace original }
//             FParamValues[i]:= strPas(NativeStr);

             repeat
                matchPos:= pos('~' + ParamLower, QBELower);
                if matchPos>0 then begin
                   tempQBE[j]:=
//                   copy(tempQBE[j], 1, matchPos-1) + FParamValues[i] +
                   copy(tempQBE[j], 1, matchPos-1) + strpas(NativeStr) + { 12/28/98 }
                   copy(tempQBE[j], matchPos + length(FParams[i]) + 1, 255);
                end;
                QBELower:= lowercase(tempQBE[j]);
             until matchPos=0;
          end;

          { Replace unassigned tilde variables with an empty string }
          matchPos:= pos('~', QBELower);
          while matchPos<>0 do begin
             curPos:= matchPos+1;
             while (curpos<=length(QBELower)) and
                   (QBELower[curpos] in ['a'..'z', '0'..'9', '_', '#']) do inc(curPos);
             tempQBE[j]:=
                copy(tempQBE[j], 1, matchPos-1) + ' ' +
                copy(tempQBE[j], curPos, 255);
             QBELower:= lowercase(tempQBE[j]);
             matchPos:= pos('~', QBELower);
          end;
       end;

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

       QBEBuf:= wwGetQueryText(tempQBE, False);

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

       try
         if FAuxiliaryTables then
            Check(dbiSetProp(hDBIObj(hStmt), stmtAUXTBLS, 1))
         else
            Check(dbiSetProp(hDBIObj(hStmt), stmtAUXTBLS, 0));

         if FBlankAsZero then
            Check(dbiSetProp(hDBIObj(hStmt), stmtBLANKS, 1));

         {$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;

       if result<>DBIERR_NONE then begin { 5/30/00 - Support error code }
         if Assigned(FOnError) then
            FOnError(self, result);
       end;
    end;

   function TwwQBE.CreateHandle: HDBICur;
   Var p:HDbiCur;
       dbResult: DBIResult;
   Begin
      if bSkipCreateHandle then begin
         bSkipCreateHandle:= False;
         result:= TempHandle;
         exit;
      end;

      result:= nil;
      bUpdateQuery:= False;

      if (FQBE.count>0) and (length(FQBE[0])>0) then try
         while True do begin
            dbResult:= PerformQuery(p);

            if (dbResult=DBIERR_NOTSUFFTABLERIGHTS) or
               (dbResult=DBIERR_NOTSUFFFIELDRIGHTS) or
               (dbResult=DBIERR_NOTSUFFFAMILYRIGHTS) then
            begin
               if not session.GetPassword then begin
                  result:= Nil;
                  break;
               end
            end
            else  begin
               Check(dbResult);

               if p=Nil then begin {Update or Insert Query}
                  bUpdateQuery:= True;
                  Result:= Nil;
                  break;
               end;

               Result:=p;

               wwSaveAnswerTable(self, p, FAnswerTable);
               break;
            end
         end
      except
         Result:= nil;
      end
      else result:= inherited CreateHandle;
   End;

    Function TwwQBE.SaveAnswerTable(tableName: string): boolean;
    begin
       result:= wwSaveAnswerTable(self, Handle, tableName);
    end;

    function TwwQBE.GetControltype: TStrings;
    begin
         Result:= FControlType;
    end;

    procedure TwwQBE.SetControlType(sel : TStrings);
    begin
       FControlType.assign(sel);
    end;

    function TwwQBE.GetLookupFields: TStrings;
    begin
       Result:= FLookupFields;
    end;

    procedure TwwQBE.SetLookupFields(sel : TStrings);
    begin
         FLookupFields.assign(sel);
    end;

    function TwwQBE.GetPictureMasks: TStrings;
    begin
       Result:= FPictureMasks
    end;

    procedure TwwQBE.SetPictureMasks(sel : TStrings);
    begin
         FPictureMasks.assign(sel);
    end;

    function TwwQBE.GetLookupLinks: TStrings;
    begin
         Result:= FLookupLinks;
    end;

    procedure TwwQBE.SetLookupLinks(sel : TStrings);
    begin
         FLookupLinks.assign(sel);
    end;

    Procedure TwwQBE.FreeLookupTables;
    var i: integer;
    begin
       for i:= lookupTables.count-1 downto 0 do
       begin
          TwwTable(lookupTables.items[i]).free;
          lookupTables.delete(i);
       end;
    end;

    { Removes obsolete links and control types }
    procedure TwwQBE.RemoveObsoleteLinks;
    begin
        wwDataSetRemoveObsolete(self, FLookupFields, FLookupLinks, FControlType);
    end;

    procedure TwwQBE.DoOnCalcFields;
    begin
       removeObsoleteLinks;
       wwDataSetDoOnCalcFields(self, FLookupFields, FLookupLinks, lookupTables);
       inherited DoOnCalcFields;
    end;


  Function TwwQBE.IsValidField(fieldName : string): boolean;
  begin
      result:= wwDataSetIsValidField(self, fieldname);
  end;

  procedure TwwQBE.SetOnFilter(val: TwwQBEFilterEvent);
  begin
     FOnFilter:= val;
     if @val=Nil then wwSetFilterFunction(Nil, self, hFilterFunction)
     else begin
        if not active then exit;
        wwSetFilterFunction(@filterQBEFunction, self, hFilterFunction);
        if hFilterFunction=nil then
           MessageDlg('Local Filtering is not supported on this QBE.',
             mtWarning, [mbok], 0);
     end

  end;

Function TwwQBE.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  {This is a lookup or a calculated field so get Lookup field value}
      method.data:= self;
      method.code:= @TwwQBE.wwFilterField;
      OtherField := wwDataSet_GetFilterLookupField(Self, curfield, method);

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

   end;

   result:= FFilterParam;
end;

Procedure TwwQBE.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;

{$ifdef wwDelphi3Up}
procedure TwwQBE.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 TwwQBE.IsSequenced: Boolean;
begin
  result:= inherited isSequenced;
  if result then begin
     if Assigned(FOnFilter) then result:= False;
  end
end;

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

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

{$endif}

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

end.