fr_class.pas

FASTREPORT报表工具,可以迅速制作报表.

    FunctionLibrary: TfrFunctionLibrary;
    Name, Category, Description: String;
  end;


const
  atNone = 10;
  atSum = 11;
  atMin = 12;
  atMax = 13;
  atAvg = 14;
  atCount = 15;


var
  VHeight: Integer;            // used for height calculation of TfrMemoView
  SBmp: TBitmap;               // small bitmap used by TfrBandView drawing
  TempBmp: TBitmap;            // temporary bitmap used by TfrMemoView
  CurDate, CurTime: TDateTime; // date/time of report starting
  CurValue: Variant;           // used for highlighting
  CurVariable: String;
  IsColumns: Boolean;
  SavedAllPages: Integer;      // number of pages in entire report
  SubValue: String;            // used in GetValue event handler
  ObjID: Integer = 0;
  BoolStr: Array[0..3] of String;
  HookList: TList;

// aggregate handling
  InitAggregate: Boolean;
  AggrBand: TfrBand;

// variables used through report building
  PrevY, PrevBottomY, ColumnXAdjust: Integer;
  Append, WasPF: Boolean;
  CompositeMode: Boolean;
  DontShowReport: Boolean;
  FLocale: TfrLocale = nil;

{----------------------------------------------------------------------------}
function frCreateObject(Typ: Byte; const ClassName: String): TfrView;
var
  i: Integer;
begin
  Result := nil;
  case Typ of
    gtMemo:      Result := TfrMemoView.Create;
    gtPicture:   Result := TfrPictureView.Create;
    gtBand:      Result := TfrBandView.Create;
    gtSubReport: Result := TfrSubReportView.Create;
    gtLine:      Result := TfrLineView.Create;
//    gtCross:     Result := TfrCrossView.Create;
    gtAddIn:
      begin
        for i := 0 to frAddInsCount - 1 do
          if frAddIns[i].ClassRef.ClassName = ClassName then
          begin
            Result := TfrView(frAddIns[i].ClassRef.NewInstance);
            Result.Create;
            Result.Typ := gtAddIn;
            break;
          end;
        if Result = nil then
        begin
          ErrorFlag := True;
          ErrorStr := ErrorStr + ClassName + #13;
          raise EClassNotFound.Create(ErrorStr);
        end;
      end;
  end;
  if Result <> nil then
  begin
    Result.ID := ObjID;
    Inc(ObjID);
  end;
end;

procedure frRegisterObject(ClassRef: TClass; ButtonBmp: TBitmap;
  const ButtonHint: String);
var
  i: Integer;
begin
  for i := 0 to frAddInsCount - 1 do
    if frAddIns[i].ClassRef = ClassRef then Exit;

  i := frAddInsCount;
  frAddIns[i].ClassRef := ClassRef;
  frAddIns[i].ButtonBmp := ButtonBmp;
  frAddIns[i].ButtonHint := ButtonHint;
  frAddIns[i].IsControl := False;
  if ButtonBmp <> nil then
    ButtonBmp.Dormant;
  Inc(frAddInsCount);
end;

procedure frRegisterControl(ClassRef: TClass; ButtonBmp: TBitmap;
  const ButtonHint: String);
var
  i: Integer;
begin
  for i := 0 to frAddInsCount - 1 do
    if frAddIns[i].ClassRef = ClassRef then Exit;

  i := frAddInsCount;
  frAddIns[i].ClassRef := ClassRef;
  frAddIns[i].ButtonBmp := ButtonBmp;
  frAddIns[i].ButtonHint := ButtonHint;
  frAddIns[i].IsControl := True;
  if ButtonBmp <> nil then
    ButtonBmp.Dormant;
  Inc(frAddInsCount);
end;

procedure frUnRegisterObject(ClassRef: TClass);
var
  i, j: Integer;
begin
  for i := 0 to frAddInsCount - 1 do
    if frAddIns[i].ClassRef = ClassRef then
    begin
      for j := i to frAddInsCount - 2 do
        frAddIns[j] := frAddIns[j + 1];
      Dec(frAddInsCount);
    end;
end;

procedure frRegisterExportFilter(Filter: TfrExportFilter;
  const FilterDesc, FilterExt: String);
var
  i: Integer;
begin
  for i := 0 to frFiltersCount - 1 do
    if frFilters[i].Filter.ClassName = Filter.ClassName then Exit;
  frFilters[frFiltersCount].Filter := Filter;
  frFilters[frFiltersCount].FilterDesc := FilterDesc;
  frFilters[frFiltersCount].FilterExt := FilterExt;
  Inc(frFiltersCount);
end;

procedure frUnRegisterExportFilter(Filter: TfrExportFilter);
var
  i, j: Integer;
begin
  for i := 0 to frFiltersCount - 1 do
    if frFilters[i].Filter.ClassName = Filter.ClassName then
    begin
      for j := i to frFiltersCount - 2 do
        frFilters[j] := frFilters[j + 1];
      Dec(frFiltersCount);
    end;
end;

procedure frRegisterFunctionLibrary(ClassRef: TClass);
var
  i: Integer;
begin
  for i := 0 to frFunctionsCount - 1 do
    if frFunctions[i].FunctionLibrary.ClassName = ClassRef.ClassName then Exit;
  frFunctions[frFunctionsCount].FunctionLibrary :=
    TfrFunctionLibrary(ClassRef.NewInstance);
  frFunctions[frFunctionsCount].FunctionLibrary.Create;
  Inc(frFunctionsCount);
end;

procedure frUnRegisterFunctionLibrary(ClassRef: TClass);
var
  i, j: Integer;
begin
  for i := 0 to frFunctionsCount - 1 do
    if frFunctions[i].FunctionLibrary.ClassName = ClassRef.ClassName then
    begin
      frInstalledFunctions.UnRegisterFunctionLibrary(frFunctions[i].FunctionLibrary);
      frFunctions[i].FunctionLibrary.Free;
      for j := i to frFunctionsCount - 2 do
        frFunctions[j] := frFunctions[j + 1];
      Dec(frFunctionsCount);
    end;
end;

procedure frRegisterTool(MenuCaption: String; ButtonBmp: TBitmap; OnClick: TNotifyEvent);
var
  i: Integer;
  Exist: Boolean;
begin
  Exist := False;
  for i := 0 to frToolsCount - 1 do
    if frTools[i].Caption = MenuCaption then
    begin
      Exist := True;
      break;
    end;
  if not Exist then
    i := frToolsCount;

  frTools[i].Caption := MenuCaption;
  frTools[i].ButtonBmp := ButtonBmp;
  frTools[i].OnClick := OnClick;
  if ButtonBmp <> nil then
    ButtonBmp.Dormant;
  if not Exist then
    Inc(frToolsCount);
end;

procedure frAddFunctionDesc(FuncLibrary: TfrFunctionLibrary;
  FuncName, Category, Description: String);
begin
  frInstalledFunctions.Add(FuncLibrary, FuncName, Category, Description);
end;

function Create90Font(Font: TFont): HFont;
var
  F: TLogFont;
begin
  GetObject(Font.Handle, SizeOf(TLogFont), @F);
  F.lfEscapement := 900;
  F.lfOrientation := 900;
  Result := CreateFontIndirect(F);
end;

function GetDefaultDataSet: TfrTDataSet;
var
  Res: TfrDataset;
begin
  Result := nil; Res := CurReport.Dataset; 
  if (CurBand <> nil) and (CurPage <> nil) and (CurPage.PageType = ptReport) then
    case CurBand.Typ of
      btReportTitle, btReportSummary,
      btPageHeader, btPageFooter,
      btMasterHeader, btMasterData, btMasterFooter,
      btGroupHeader, btGroupFooter:
        Res := CurPage.Bands[btMasterData].DataSet;
      btDetailData, btDetailFooter:
        Res := CurPage.Bands[btDetailData].DataSet;
      btSubDetailData, btSubDetailFooter:
        Res := CurPage.Bands[btSubDetailData].DataSet;
      btCrossData, btCrossFooter:
        Res := CurPage.Bands[btCrossData].DataSet;
    end;
  if (Res <> nil) and (Res is TfrDBDataset) then
    Result := TfrDBDataSet(Res).GetDataSet;
end;

function ReadString(Stream: TStream): String;
begin
  if frVersion >= 23 then
    Result := frReadString(Stream) else
    Result := frReadString22(Stream);
end;

procedure ReadMemo(Stream: TStream; Memo: TStrings);
begin
  if frVersion >= 23 then
    frReadMemo(Stream, Memo) else
    frReadMemo22(Stream, Memo);
end;

procedure CreateDS(Desc: String; var DataSet: TfrDataSet; var IsVirtualDS: Boolean);
begin
  if (Desc <> '') and (Desc[1] in ['1'..'9']) then
  begin
    DataSet := TfrUserDataSet.Create(nil);
    DataSet.RangeEnd := reCount;
    DataSet.RangeEndCount := StrToInt(Desc);
    IsVirtualDS := True;
  end
  else
    DataSet := frFindComponent(CurReport.Owner, Desc) as TfrDataSet;
  if DataSet <> nil then
    DataSet.Init;
end;

procedure DoError(E: Exception);
var
  i: Integer;
  s: String;
begin
  ErrorFlag := True;
  ErrorStr := frLoadStr(SErrorOccured);
  if CurView <> nil then
  begin
    for i := 0 to CurView.Memo.Count - 1 do
      ErrorStr := ErrorStr + #13 + CurView.Memo[i];
    s := frLoadStr(SObject) + ' ' + CurView.Name + #13;
  end
  else
    s := '';
  ErrorStr := ErrorStr + #13#13 + frLoadStr(SDoc) + ' ' + CurReport.Name +
    #13 + s + #13 + E.Message;
  MasterReport.Terminated := True;
end;

procedure ParseObjectName(const Name: String; var Obj: TfrObject; var Prop: String);
var
  ObjName: String;
  PageNo: Integer;

  procedure DefineProperties(Obj: TfrObject);
  begin
    if Obj <> nil then
      if Obj.PropList.Count = 0 then
        Obj.DefineProperties;
  end;

begin
  Obj := CurView;
  Prop := Name;
  if Pos('.', Name) <> 0 then
  begin
    ObjName := Copy(Name, 1, Pos('.', Name) - 1);
    Prop := Copy(Name, Pos('.', Name) + 1, 255);

    if (Pos('PAGE', AnsiUpperCase(ObjName)) = 1) and (Length(ObjName) > 4) and
       (ObjName[5] in ['0'..'9']) then
    begin
      PageNo := StrToInt(Copy(ObjName, 5, 255));
      Obj := CurReport.Pages[PageNo - 1];
    end
    else
    begin
      Obj := CurReport.FindObject(ObjName);

      if Obj = nil then
      begin
        DefineProperties(CurView);
        if (CurView <> nil) and (CurView.PropRec[ObjName] <> nil) then
        begin
          Obj := CurView;
          Prop := Name;
        end
      end;
    end;
  end;

  DefineProperties(Obj);
end;


{ TfrObject }

constructor TfrObject.Create;
begin
  inherited Create;
  PropList := TList.Create;
end;

destructor TfrObject.Destroy;
begin
  ClearPropList;
  PropList.Free;
  inherited Destroy;
end;

procedure TfrObject.ClearPropList;
var
  p: PfrPropRec;
begin
  while PropList.Count > 0 do
  begin
    p := PropList[0];
    if p^.Enum <> nil then
      p^.Enum.Free;
    Dispose(p);
    PropList.Delete(0);
  end;
end;

procedure TfrObject.AddProperty(PropName: String; PropType: TfrDataTypes;
  PropEditor: TNotifyEvent);
var
  p: PfrPropRec;
begin
  New(p);
  p^.PropName := PropName;
  p^.PropType := PropType;
  p^.PropEditor := PropEditor;
  p^.Enum := nil;
  PropList.Add(p);
end;

procedure TfrObject.AddEnumProperty(PropName: String; Enum: String;
  const EnumValues: Array of Variant);
var
  p: PfrPropRec;
  vv: Variant;
begin
  New(p);
  p^.PropName := PropName;
  p^.PropType := [frdtEnum];
  p^.PropEditor := nil;
  p^.Enum := TStringList.Create;
  frSetCommaText(Enum, p^.Enum);

  if TVarData(EnumValues[0]).VType = varArray + varVariant then
    vv := EnumValues[0] else