fr_class.pas

FastReport2.51.FS.Delphi567.rar是DELPHI中的一个报表控件.

    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;

function HexChar(Nibble: Byte): Char;

begin

  if (Nibble < 10) then

    Result := Chr(Ord('0') + Nibble)

  else

    Result := Chr(Ord('A') + (Nibble - 10));

end;

function HexChar1(Ch: Char): Byte;

begin

  Ch := UpCase(Ch);

  if (Ch <= '9') then

    Result := Ord(Ch) - Ord('0')

  else

    Result := Ord(Ch) - Ord('A') + 10;

end;

function StrToHex(const s: string): string;

var

  Len, i: Integer;

  Ch, NibbleH, NibbleL: Byte;

begin

  Len := Length(s);

  SetLength(Result, Len shl 1);

  for i := 1 to Len do
  begin

    Ch := Ord(s[i]);

    NibbleH := (Ch shr 4) and $F;

    NibbleL := Ch and $F;

    Result[i shl 1 - 1] := HexChar(NibbleH);

    Result[i shl 1] := HexChar(NibbleL);

  end;

end;

function HexToStr(const s: string): string;

var

  Len, i: Integer;

  Ch: Byte;

  NibbleH, NibbleL: Byte;

begin

  Len := Length(s);

  SetLength(Result, Len shr 1);

  for i := 1 to Len shr 1 do
  begin

    NibbleH := HexChar1(s[i shl 1 - 1]);

    NibbleL := HexChar1(s[i shl 1]);

    Ch := NibbleH shl 4 or NibbleL;

    Result[i] := Chr(Ch);

  end;

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

    vv := VarArrayOf(EnumValues);

  if vv[0] = Null then

    p^.EnumValues := Null
  else

    p^.EnumValues := vv;

  PropList.Add(p);

end;

procedure TfrObject.DelProperty(PropName: string);

var

  p: PfrPropRec;

begin

  p := PropRec[PropName];

  if p <> nil then

  begin

    PropList.Delete(PropList.IndexOf(p));

    Dispose(p);

  end;

end;

procedure TfrObject.DefineProperties;

begin

  // abstract method

end;

procedure TfrObject.SetPropValue(Index: string; Value: Variant);

begin

  // abstract method

end;

function TfrObject.DoMethod(MethodName: string; Par1, Par2, Par3: Variant):
  Variant;

begin

  Result := Null;

end;

function TfrObject.GetPropValue(Index: string): Variant;

begin

  Result := Null;

end;

function TfrObject.GetPropRec(Index: string): PfrPropRec;

var

  i: Integer;

  p: PfrPropRec;

begin

  Result := nil;

  for i := 0 to PropList.Count - 1 do

  begin

    p := PropList[i];

    if AnsiCompareText(p^.PropName, Index) = 0 then

    begin

      Result := p;

      break;

    end;

  end;

end;

procedure TfrObject.SetFontProp(Font: TFont; Prop: string; Value: Variant);

begin

  if Prop = 'FONT.NAME' then

    Font.Name := Value

  else if Prop = 'FONT.SIZE' then

    Font.Size := Value

  else if Prop = 'FONT.STYLE' then

    Font.Style := frSetFontStyle(Value)

  else if Prop = 'FONT.COLOR' then

    Font.Color := Value

end;

function TfrObject.GetFontProp(Font: TFont; Prop: string): Variant;

begin

  Result := Null;

  if Prop = 'FONT.NAME' then

    Result := Font.Name

  else if Prop = 'FONT.SIZE' then

    Result := Font.Size

  else if Prop = 'FONT.STYLE' then

    Result := frGetFontStyle(Font.Style)

  else if Prop = 'FONT.COLOR' then

    Result := Font.Color

end;

function TfrObject.LinesMethod(Lines: Tstrings; MethodName, LinesName: string;

  Par1, Par2, Par3: Variant): Variant;

begin

  if MethodName = 'SETINDEXPROPERTY' then

  begin

    // Par1 is index property name (e.g. 'Lines')

    // Par2 is index (e.g. 1)

    // Par3 is value which you must assign to the index property

    if Par1 = LinesName then

      Lines[Par2] := Par3;

  end

  else if MethodName = 'GETINDEXPROPERTY' then

  begin

    // Par1 is index property name

    // Par2 is index

    // Par3 is Null - don't use it

    if Par1 = LinesName then

      Result := Lines[Par2];

  end

  else if MethodName = LinesName + '.ADD' then

    Lines.Add(frParser.Calc(Par1))

  else if MethodName = LinesName + '.CLEAR' then

    Lines.Clear

  else if MethodName = LinesName + '.DELETE' then

    Lines.Delete(frParser.Calc(Par1))

  else if MethodName = LinesName + '.INDEXOF' then

    Result := Lines.IndexOf(frParser.Calc(Par1))

end;

{ TfrView }

constructor TfrView.Create;

begin

  inherited Create;

  Parent := nil;

  Memo := TStringList.Create;

  Memo1 := TStringList.Create;

  Script := TStringList.Create;

  FrameWidth := 1;

  FrameColor := clBlack;

  FillColor := clNone;

  Format := 2 * 256 + Ord(DecimalSeparator);

  BaseName := 'View';

  Visible := True;

  StreamMode := smFRF;

  ScaleX := 1;
  ScaleY := 1;

  OffsX := 0;
  OffsY := 0;

  Flags := flStretched;

  gapx := 2;
  gapy := 1;

  Typ := gtAddIn;

end;

destructor TfrView.Destroy;

begin

  Memo.Free;

  Memo1.Free;

  Script.Free;

  inherited Destroy;

end;

procedure TfrView.Assign(From: TfrView);

var

  Stream: TMemoryStream;

begin

  Name := From.Name;

  Typ := From.Typ;

  Selected := From.Selected;

  Stream := TMemoryStream.Create;

  frVersion := frCurrentVersion;

  From.StreamMode := smFRF;

  From.SaveToStream(Stream);

  Stream.Position := 0;

  StreamMode := smFRF;

  LoadFromStream(Stream);

  Stream.Free;

end;

procedure TfrView.DefineProperties;

begin

  ClearPropList;

  AddProperty('Name', [frdtString, frdtOneObject], nil);

  AddProperty('Left', [frdtSize], nil);

  AddProperty('Top', [frdtSize], nil);

  AddProperty('Width', [frdtSize], nil);

  AddProperty('Height', [frdtSize], nil);

  AddProperty('Flags', [], nil);

  if (ClassName <> 'TfrBandView') and (ClassName <> 'TfrSubReportView') then

  begin

    AddProperty('FrameTyp', [frdtInteger], nil);

    AddProperty('FrameWidth', [frdtSize, frdtFloat], nil);

    AddProperty('FrameColor', [frdtColor], nil);

    AddEnumProperty('FrameStyle',

      'psSolid;psDash;psDot;psDashDot;psDashDotDot;psDouble',

      [psSolid, psDash, psDot, psDashDot, psDashDotDot, psDouble]);

    AddProperty('FillColor', [frdtColor], nil);

    AddProperty('Tag', [frdtHasEditor, frdtOneObject], frTagEditor);

    AddEnumProperty('BandAlign',

      'baNone;baLeft;baRight;baCenter;baWidth;baBottom;baTop;baRest',

      [baNone, baLeft, baRight, baCenter, baWidth, baBottom, baTop, baRest]);

  end;

  AddProperty('Visible', [frdtBoolean], nil);

  AddProperty('Memo', [frdtOneObject, frdtHasEditor], frMemoEditor);

  AddProperty('Memo.Count', [], nil);

  AddProperty('Restrictions', [frdtHasEditor], frRestrEditor);

end;

procedure TfrView.SetPropValue(Index: string; Value: Variant);

begin

  Index := AnsiUpperCase(Index);

  if Index = 'NAME' then

    Name := Value

  e