fr_class.pas

航空人身保险信息管理系统使用SQL和DELHPI开发

    constructor CreateSplitter(SplitTo: TStrings);
    destructor Destroy; override;
    procedure SplitMemo(Memo: TStrings);
    procedure SplitScript(Script: Tstrings);
  end;

  PfrFunctionDesc = ^TfrFunctionDesc;
  TfrFunctionDesc = record
    FunctionLibrary: TfrFunctionLibrary;
    Name, Category, Description: String;
  end;

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

var
  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;
 
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;