dbchart.pas

来自「Delphi TeeChartPro.6.01的源代码」· PAS 代码 · 共 1,041 行 · 第 1/2 页

          ASeries.Add(tmpMand,tmpXLabel,tmpColor);
        end
        else { existing point, do aggregation }
        With MandaList do
        Case AggPrefix of
          dcaSum:   Value[tmpIndex]:=Value[tmpIndex]+tmpMand;
          dcaCount: Value[tmpIndex]:=Value[tmpIndex]+1;
          dcaHigh:  if tmpMand>Value[tmpIndex] then Value[tmpIndex]:=tmpMand;
          dcaLow:   if tmpMand<Value[tmpIndex] then Value[tmpIndex]:=tmpMand;
          dcaAverage: begin
                        Value[tmpIndex]:=Value[tmpIndex]+tmpMand;
                        { trick: use the color as temporary count for average }
                        ASeries.ValueColor[tmpIndex]:=ASeries.ValueColor[tmpIndex]+1;
                      end;
        end;
      end
      else
      With DestSeries.ASeries do
      begin
        With ValuesList do
        for t:=2 to Count-1 do
            With TValueListAccess(ValueList[t]) do
            if Assigned(IData) then TempValue:=TField(IData).AsFloat
                               else TempValue:=0;

        if NotMandatoryValueList.ValueSource='' then
           if YManda then
              AddY(tmpMand,tmpXLabel,tmpColor)
           else
              AddX(tmpMand,tmpXLabel,tmpColor)
        else
           if YManda then { 5.01 }
              AddXY(tmpNotMand,tmpMand,tmpXLabel,tmpColor)
           else
              AddXY(tmpMand,tmpNotMand,tmpXLabel,tmpColor);
      end;
    end;

    Function GetFieldValue(AField:TField):Double;
    begin
      With AField do
      if FieldKind=fkAggregate then result:=Value
                               else result:=AsFloat;
    end;

    Procedure AddSingleRecord;
    var t       : Integer;
        tmpName : String;
    begin
      With tmpSeries do
      for t:=1 to NumFields do
      begin
        tmpName:=TeeExtractField(MandaList.ValueSource,t);
        if ASeries.XLabelsSource='' then tmpXLabel:=tmpName;

        if tmpName='' then
           tmpMand:=0
        else
           tmpMand:=GetFieldValue(ADataSet.FieldByName(tmpName));

        AddToSeries(tmpSeries);
      end;
    end;

    Function CalcXPos:String; { from DateTime to Label }
    var Year    : Word;
        Month   : Word;
        Day     : Word;
        Hour    : Word;
        Minute  : Word;
        Second  : Word;
        MSecond : Word;
    begin
      result:='';
      DecodeDate(tmpNotMand,Year,Month,Day);
      Case tmpSeries.GroupPrefix of
       dgHour: begin
                 DecodeTime(tmpNotMand,Hour,Minute,Second,MSecond);
                 result:=FormatDateTime('dd hh:mm',Trunc(tmpNotMand)+Hour/24.0);  // 5.02
               end;
        dgDay: result:=FormatDateTime('dd/MMM',Trunc(tmpNotMand)); // 5.02
       dgWeek: result:=TeeStr(DateToWeek(tmpNotMand,Year))+'/'+TeeStr(Year);
    dgWeekDay: result:=ShortDayNames[DayOfWeek(tmpNotMand)];
      dgMonth: result:=FormatDateTime('MMM/yy',EncodeDate(Year,Month,1));
    dgQuarter: result:=TeeStr(1+((Month-1) div 3))+'/'+TeeStr(Year); // 5.02
       dgYear: result:=FormatDateTime('yyyy',EncodeDate(Year,1,1));
      end;
    end;

  Begin
    With tmpSeries do
    Begin
      if GroupPrefix=dgNone then
         if Assigned(LabelField) then tmpXLabel:=LabelField.DisplayText
                                 else tmpXLabel:=''
      else
      begin
        tmpNotMand:=LabelField.AsFloat;
        tmpXLabel:=CalcXPos;
      end;

      if AggPrefix<>dcaNone then tmpColor:=clTeeColor
      else
      if Assigned(ColorField) then
         tmpColor:=ColorField.AsInteger
      else
      {$IFNDEF CLX} // CLX limitation
      if Assigned(MandaField) and MandaField.IsNull then
         tmpColor:=clNone
      else
      {$ENDIF}
         tmpColor:=clTeeColor;

      if NumFields=1 then
      begin
        if (not HasAnyDataSet) and (not Assigned(LabelField)) then
           tmpXLabel:=MandaList.ValueSource;
           
        With TValueListAccess(ASeries.NotMandatoryValueList) do
          if Assigned(IData) then tmpNotMand:=TField(IData).AsFloat else tmpNotMand:=0;
          if Assigned(MandaField) then tmpMand:=GetFieldValue(MandaField)
                                  else tmpMand:=0;

        // add summary point
        AddToSeries(tmpSeries);
      end
      else AddSingleRecord
    end;
  end;

Var FListSeries : TDBChartSeriesList;

  Procedure FillTempSeriesList;

   Function GetDataSet(ASeries:TChartSeries):TDataSet;
   begin
     With ASeries do
     if DataSource is TDataSet then result:=TDataSet(DataSource)
     else
     if DataSource is TDataSource then
        result:=TDataSource(DataSource).DataSet
     else
        result:=nil;
   end;

   Function IsDataSet(ASeries:TChartSeries):Boolean;
   var tmp : TDataSet;
   begin
     tmp:=GetDataSet(ASeries);
     if Assigned(tmp) then
     begin
       result:=tmp=ADataSet;
       HasAnyDataSet:=ASeries.DataSource is TDataSet;
     end
     else result:=False;
   end;

   Procedure AddList(tmpSeries:TChartSeries);
   var tmp : TDataSet;

      Function GetAField(Const FieldName:String):TField;
      begin
        if FieldName='' then result:=nil
                        else result:=tmp.FieldByName(FieldName);
      end;

      Function GetAFieldPrefix(St:String; Var Prefix:String):TField;
      begin
        Prefix:=TeeGetDBPart(1,St);
        if Prefix<>'' then St:=TeeGetDBPart(2,St);
        result:=GetAField(St);
      end;

   var t        : Integer;
       tmpAgg   : String;
       tmpGroup : String;
       tmpV     : TValueListAccess;
   begin
     SetLength(FListSeries,Length(FListSeries)+1);
     With FListSeries[Length(FListSeries)-1] do
     begin
       ASeries   :=tmpSeries;
       YManda    :=ASeries.YMandatory;
       MandaList :=ASeries.MandatoryValueList;
       NumFields :=TeeNumFields(MandaList.ValueSource);
       tmp:=GetDataSet(ASeries);
       if Assigned(tmp) then
       With ASeries do
       begin
         LabelField:=GetAFieldPrefix(XLabelsSource,tmpGroup);

         // try to find #SORTASC# or #SORTDESC# in label grouping
         LabelSort:=StrToDBOrder(tmpGroup);
         if LabelSort=loNone then
            GroupPrefix:=StrToDBGroup(tmpGroup) // find #HOUR# etc
         else
            GroupPrefix:=dgNone;

         ColorField:=GetAField(ColorSource);
         MandaField:=GetAFieldPrefix(TeeExtractField(MandaList.ValueSource,1),tmpAgg);

         if tmpAgg<>'' then
         begin
           tmpAgg:=UpperCase(tmpAgg);
           if tmpAgg='SUM'   then AggPrefix:=dcaSum else
           if tmpAgg='COUNT' then AggPrefix:=dcaCount else
           if tmpAgg='HIGH'  then AggPrefix:=dcaHigh else
           if tmpAgg='LOW'   then AggPrefix:=dcaLow else
           if tmpAgg='AVG'   then AggPrefix:=dcaAverage else
                                  AggPrefix:=dcaNone;
         end
         else
         begin
           AggPrefix:=dcaNone;
           for t:=0 to ValuesList.Count-1 do
           begin
             tmpV:=TValueListAccess(ValuesList[t]);
             if tmpV<>MandaList then tmpV.IData:=GetAField(tmpV.ValueSource);
           end;
         end;
       end;
     end;
   end;

  var t         : Integer;
      tmpSeries : TChartSeries;
  begin
    FListSeries:=nil;
    if Assigned(ASeries) then
    begin
      AddList(ASeries);
      HasAnyDataSet:=ASeries.DataSource=ADataSet;
    end
    else
    for t:=0 to SeriesCount-1 do
    Begin
      tmpSeries:=Series[t];
      if IsDataSet(tmpSeries) and
         (tmpSeries.MandatoryValueList.ValueSource<>'') then
            AddList(tmpSeries);
    end;
  end;

  Procedure TraverseDataSet;
  Var b : TBookMark;
      t : Integer;
      tt: Integer;
  begin
    With ADataSet do
    begin
      DisableControls;
      try
        b:=GetBookMark;
        try
          First;
          While not EOF do
          try
            if Assigned(FOnProcessRecord) then FOnProcessRecord(Self,ADataSet);
            for t:=0 to Length(FListSeries)-1 do
                if FListSeries[t].ASeries.DataSource=ADataSet then
                   ProcessRecord(FListSeries[t]);
            Next;
          except
            on EAbort do break; { <-- exit while loop !!! }
          end;

          for t:=0 to Length(FListSeries)-1 do
          With FListSeries[t] do
          begin
            if AggPrefix=dcaAverage then
            begin
              for tt:=0 to ASeries.Count-1 do
              begin
                MandaList.Value[tt]:=MandaList.Value[tt]/ASeries.ValueColor[tt];
                ASeries.ValueColor[tt]:=clTeeColor;
              end;
            end;

            if (AggPrefix<>dcaNone) and (LabelSort<>loNone) then
               ASeries.SortByLabels(LabelSort);
          end;
        finally
          try
            GotoBookMark(b);
          finally
            FreeBookMark(b);
          end;
        end;
      finally
        EnableControls;
      end;
    end;
  end;

Var OldCursor : TCursor;
    t         : Integer;
    OldPaint  : Boolean;
Begin
  if not IUpdating then
  With ADataSet do
  if Active then
  Begin
    IUpdating:=True;
    FListSeries:=nil;
    HasAnyDataSet:=False;
    try
      FillTempSeriesList;
      if Length(FListSeries)>0 then
      Begin
        OldCursor:=Screen.Cursor;
        if FShowGlassCursor then Screen.Cursor:=crHourGlass;

        OldPaint:=AutoRepaint;
        AutoRepaint:=False;
        try
          for t:=0 to Length(FListSeries)-1 do
              FListSeries[t].ASeries.Clear;
          if HasAnyDataSet then TraverseDataSet
          else
          begin
            {$IFDEF TEEOCX}
            ADataSet.Resync([]);
            {$ENDIF}
            if Assigned(FOnProcessRecord) then FOnProcessRecord(Self,ADataSet);
            for t:=0 to Length(FListSeries)-1 do
                if TDataSource(FListSeries[t].ASeries.DataSource).DataSet=ADataSet then
                begin
                  ProcessRecord(FListSeries[t]);
                end;
          end;

          for t:=0 to Length(FListSeries)-1 do
          begin
            FListSeries[t].ASeries.CheckOrder;
            FListSeries[t].ASeries.RefreshSeries;
          end;
        finally
          AutoRepaint:=OldPaint;
          Invalidate;
          if FShowGlassCursor then Screen.Cursor:=OldCursor;
        end;
      end;
    finally
      FListSeries:=nil;
      IUpdating:=False;
    end;
  end;
end;

Procedure TCustomDBChart.RefreshData;
var t : Integer;
Begin
  for t:=0 to IDataSources.Count-1 do
      RefreshDataSet(IDataSources[t].DataSet,nil);
End;

Procedure FillDataSetFields(DataSet:TDataSet; Proc:TGetStrProc);
var t : Integer;
begin
  with DataSet do
  begin
    if FieldCount > 0 then
       for t:=0 to FieldCount-1 do Proc(Fields[t].FieldName)
    else
    Begin
      FieldDefs.Update;
      for t:=0 to FieldDefs.Count-1 do Proc(FieldDefs[t].Name);
    end;
  end;
end;

Procedure TCustomDBChart.FillSeriesSourceItems(ASeries:TChartSeries; Proc:TGetStrProc);
Begin
  With ASeries do
  if Assigned(DataSource) then
  begin
    if DataSource is TDataSource then
       FillDataSetFields(TDataSource(DataSource).DataSet,Proc)
    else
    if DataSource is TDataSet then
       FillDataSetFields(TDataSet(DataSource),Proc);
  end;
end;

Procedure TCustomDBChart.FillValueSourceItems(AValueList:TChartValueList; Proc:TGetStrProc);
Begin
  With AValueList.Owner do
  if Assigned(DataSource) then
  Begin
    if (DataSource is TDataSet) or (DataSource is TDataSource) then
       FillSeriesSourceItems(AValueList.Owner,Proc)
    else
       inherited;
  end;
end;

Procedure TCustomDBChart.Assign(Source:TPersistent);
begin
  if Source is TCustomDBChart then
  With TCustomDBChart(Source) do
  begin
    Self.AutoRefresh    :=AutoRefresh;
    Self.RefreshInterval:=RefreshInterval;
    Self.ShowGlassCursor:=ShowGlassCursor;
  end;
  inherited;
end;

{ 5.01 Reported by : Timo Goebel <[e-mail]> }
Function DateToWeek(ADate:TDateTime; Var Year:Word):Integer;
const FirstWeekDay  = 2;  // 2: Monday (ISO-8601)
      FirstWeekDate = 4; // 4: First four day-week (ISO-8601)
var Month : Word;
    Day   : Word;
begin
  ADate:=ADate-((DayOfWeek(ADate)-FirstWeekDay+7) mod 7)+ 7-FirstWeekDate;
  DecodeDate(ADate,Year,Month,Day);
  Result:=(Trunc(ADate-EncodeDate(Year,1,1)) div 7)+1;
end;

Function DateToWeekOld(Const ADate:TDateTime; Var Year:Word):Integer;
Const FirstDay=0; { Monday }
Var d,m,y,j,j0,j1,Week : Word;
begin
  DecodeDate(ADate,y,m,d);
  if (m < 3) then
    j := 1461*(y-1) div 4 + (153*(m+9)+2) div 5 + d
  else
    j := 1461*y div 4 + (153*(m-3)+2) div 5 + d;

  j0:=1461*(y-1) DIV 4 + 310;
  j0:=j0-(j0-FirstDay) MOD 7;

  If (j<j0) then
  begin
    j0 := 1461*(y-2) DIV 4 + 310;
    j0 := j0 - (j0-FirstDay) MOD 7;
    Week:=1 + (j-j0) DIV 7;
    Year:=y-1;
  end
  else
  begin
    j1 := 1461*y div 4 + 310;
    j1 := j1 - (j1-FirstDay) mod 7;
    if j<j1 then
    begin
      Week:=1 + (j-j0) div 7;
      Year:=y;
    end
    else
    begin
      Week:=1;
      Year:=y+1;
    end;
  end;
  result:=Week;
End;

Function TeeFieldType(AType:TFieldType):TTeeFieldType;
begin
  Case AType of
    ftAutoInc,
    ftSmallint,
    ftInteger,
    ftLargeInt,
    ftWord,
    ftFloat,
    ftCurrency,
    ftBCD        : result:=tftNumber;
    ftDate,
    ftTime,
    ftDateTime   : result:=tftDateTime;
    ftString,
    ftFixedChar,
    ftWideString : result:=tftText;
  else             result:=tftNone;
  end;
end;

Function TeeGetDBPart(Num:Integer; St:String):String;
var i : Integer;
begin
  result:='';
  if Copy(St,1,1)='#' then
  begin
    Delete(St,1,1);
    i:=Pos('#',St);
    if i>0 then
       if Num=1 then result:=Copy(St,1,i-1)
       else
       if Num=2 then result:=Copy(St,i+1,Length(St)-i);
  end;
end;

Function StrToDBGroup(St:String):TTeeDBGroup;
begin
  St:=UpperCase(St);
  if St='HOUR' then result:=dgHour else
  if St='DAY' then result:=dgDay else
  if St='WEEK' then result:=dgWeek else
  if St='WEEKDAY' then result:=dgWeekDay else
  if St='MONTH' then result:=dgMonth else
  if St='QUARTER' then result:=dgQuarter else
  if St='YEAR' then result:=dgYear else
     result:=dgNone;
end;

Function StrToDBOrder(St:String):TChartListOrder;
begin
  St:=UpperCase(St);
  if St='SORTASC' then result:=loAscending
  else
  if St='SORTDES' then result:=loDescending
  else
     result:=loNone;
end;

end.