rvproj.pas

医院病历管理简易版,完全用DELPHI实现.

            finally
              OnPrint := SaveOnPrint;
              OnBeforePrint := SaveBeforePrint;
              OnAfterPrint := SaveAfterPrint;
              SystemPrinter.UnitsFactor := SavedUnitsFactor;
            end; { tryf }
          end; { else }
        end; { with }
      end else begin { Not a TRvSystem, treat as TBaseReport }
        with Engine as TBaseReport do begin
          SavedUnitsFactor := UnitsFactor;
          UnitsFactor := 1;
          if Printing then begin
            try
              TRaveProjectManager(Project).BaseReport := Engine as TBaseReport;
              RSPrint(Engine as TBaseReport);
            finally
              UnitsFactor := SavedUnitsFactor;
            end; { tryf }
          end else begin { Not printing }
            SaveOnPrint := OnPrint;
            OnPrint := RSPrint;
            SaveBeforePrint := OnBeforePrint;
            OnBeforePrint := RSBeforePrint;
            SaveAfterPrint := OnAfterPrint;
            OnAfterPrint := RSAfterPrint;
            try
              Execute;
            finally
              OnPrint := SaveOnPrint;
              OnBeforePrint := SaveBeforePrint;
              OnAfterPrint := SaveAfterPrint;
              UnitsFactor := SavedUnitsFactor;
            end; { tryf }
          end; { else }
        end; { with }
      end; { else }
    end else begin { No Engine assigned, create TRvSystem component }
      with TRvSystem.Create(Application.MainForm) do try
        DefaultDest := PrintDestination;
        TitleSetup := Trans('Output Options');
        TitleStatus := Trans('Report Status');
        TitlePreview := Trans('Report Preview');
        if AllowSetup then begin
          SystemSetups := SystemSetups + [ssAllowSetup];
        end else begin
          SystemSetups := SystemSetups - [ssAllowSetup];
        end; { else }
        SystemPreview.GridHoriz := PreviewGridHoriz;
        SystemPreview.GridVert := PreviewGridVert;
        SystemPreview.GridPen.Color := PreviewGridColor;
        SystemPreview.GridPen.Style := PreviewGridPenStyle;
        SystemPreview.RulerType := PreviewRulerType;
        SystemPreview.MarginPercent := 2.5;
        SystemPreview.ShadowDepth := PreviewShadowDepth;
        SystemPreview.ZoomInc := PreviewZoomInc;
        SystemPreview.ZoomFactor := PreviewZoomFactor;
        SystemPreview.FormState := PreviewWindowState;
        SystemPreview.Monochrome := PreviewMonochrome;
        SystemFiler.AccuracyMethod := amAppearance;
        if AlwaysGenerate then begin
          SystemOptions := SystemOptions + [soUseFiler];
        end; { if }
        SaveOnPrint := OnPrint;
        OnPrint := RSPrint;
        SaveBeforePrint := nil;
        OnBeforePrint := RSBeforePrint;
        SaveAfterPrint := nil;
        OnAfterPrint := RSAfterPrint;
        SystemFiler.StreamMode := smTempFile;
        try
          Execute;
        finally
          OnPrint := SaveOnPrint;
          OnBeforePrint := SaveBeforePrint;
          OnAfterPrint := SaveAfterPrint;
        end; { tryf }
      finally
        Free;
      end; { with }
    end; { else }
  finally
    if RaveDataSystem <> nil then begin
      RaveDataSystem.ReleaseControl;
    end;
    TRaveProjectManager(Project).AfterReport;

    if Assigned(CurrentDesigner) then begin
      CurrentDesigner.Invalidate;
    end; { if }

  { Restore designed state for report and all global pages }
(*
    RestoreDesigned;
    For I1 := 0 to TRaveProjectManager(Project).GlobalPageList.Count - 1 do begin
      TRaveReport(TRaveProjectManager(Project).GlobalPageList[I1]).RestoreDesigned;
    end; { for }
*)
    TRaveProjectManager(Project).FPrinting := false;
  end; { if }
end;  { InternalExecute }

procedure TRaveReport.Execute(Engine: TRPComponent);
var
  LRaveContainer: TRaveContainerControl;
  LStream: TStream;
begin { Execute }
  HoldAddDeleteComponents := true;
  LStream := TMemoryStream.Create;
  try
    TRaveProjectManager(Project).ReportToStream(Self, LStream);
    LRaveContainer := TRaveContainerControl.Create(nil);
    try
      FExecProject := TRaveProjectManager.Create(LRaveContainer);
      try
        FExecProject.MasterProject := TRaveProjectManager(Project);
        try
          LStream.Position := 0;
          FExecProject.NoDesigner := true;
          FExecProject.LoadFromStream(LStream);
          FExecProject.Params.Assign(TRaveProjectManager(Project).Params);
        finally
          FExecProject.MasterProject := nil;
        end;
        FExecProject.FindReport(FullName,true).InternalExecute(Engine);
      finally
        FreeAndNil(FExecProject);
      end;
    finally
      FreeAndNil(LRaveContainer);
    end;
  finally
    HoldAddDeleteComponents := false;
    FreeAndNil(LStream);
  end;
end;  { Execute }

{ class TRaveModuleManager }

constructor TRaveModuleManager.Create(AProjectManager: TRaveProjectManager);
begin { Create }
  inherited Create;
  ModuleList := TList.Create;
  FProjectManager := AProjectManager;
end;  { Create }

destructor TRaveModuleManager.Destroy;
var
  I1: integer;
begin { Destroy }
  for I1 := 0 to ModuleList.Count - 1 do begin
    TRaveModule(ModuleList[I1]).Free;
  end; { for }
  FreeAndNil(ModuleList);
  inherited Destroy;
end;  { Destroy }

function TRaveModuleManager.ModuleIndex(ModuleName: string): integer;
var
  I1: integer;
begin { ModuleIndex }
  for I1 := 0 to ModuleList.Count - 1 do begin
    if SameStr(TRaveModule(ModuleList[I1]).ModuleName,ModuleName) then begin
      Result := I1;
      Exit;
    end; { if }
  end; { for }
  Result := -1;
end;  { ModuleIndex }

function TRaveModuleManager.LoadModule(ModuleName: string): integer;
var
  Module: TRaveModule;
  Stream: TMemoryStream;

  { included for D4 compatibility }
  function IncludeTrailingBackslash(const S: string): string;
  begin
    Result := S;
    if not IsPathDelimiter(Result, Length(Result)) then Result := Result + '\';
  end;
begin { LoadModule }
  Stream := TMemoryStream.Create;
  try
    Stream.LoadFromFile(
      IncludeTrailingBackslash(ExtractFilePath(Application.ExeName))
      + ModuleName + {Trans-}'.RVC');
    Module := CreateRaveModule(Stream,ProjectManager,nil);
  finally
    Stream.Free;
  end; { tryf }
  Result := ModuleList.Add(Module);
  RegisterRaveModule(Module);
end;  { LoadModule }

function TRaveModuleManager.GetModule(ModuleName: string): TRaveModule;
var
  I1: integer;
begin { GetModule }
  I1 := ModuleIndex(ModuleName);
  if I1 < 0 then begin { Try to load module }
    I1 := LoadModule(ModuleName);
    if I1 < 0 then begin
      RaiseError(Trans(Format({Trans+}'Could not load module [%s]',[ModuleName])));
    end; { if }
  end; { if }
  Result := TRaveModule(ModuleList[I1]);
end;  { GetModule }

function TRaveModuleManager.FindModule(ModuleName: string): TRaveModule;
var
  I1: integer;
begin { FindModule }
  I1 := ModuleIndex(ModuleName);
  if I1 < 0 then begin
    Result := nil;
  end else begin
    Result := TRaveModule(ModuleList[I1]);
  end; { else }
end;  { FindModule }

procedure TRaveModuleManager.LoadModules(StreamHelper: TStreamHelper);
var
  I1: integer;
  I2: integer;
  ModCount: integer;
  Module: TRaveModule;
  OldModule: TRaveModule;
begin { LoadModules }
  with StreamHelper do begin
    ModCount := ReadIndex;
    for I1 := 1 to ModCount do begin
      ReadString; // Module name

      StartReadBlock;
    // Load the module from the stream
      Module := CreateRaveModule(Stream,ProjectManager,nil);
    // Register the module
      I2 := ModuleIndex(Module.ModuleName);
      if I2 >= 0 then begin // Already registered, replace
        OldModule := ModuleList[I2];
        ModuleList[I2] := Module;
        FreeAndNil(OldModule);
      end else begin // Add module
        ModuleList.Add(Module);
      end; { else }
      RegisterRaveModule(Module);
      FinishReadBlock;
    end; { for }
  end; { with }
end;  { LoadModules }

procedure TRaveModuleManager.SaveModules(StreamHelper: TStreamHelper);
var
  I1: integer;
begin { SaveModules }
  with StreamHelper do begin
    WriteIndex(ModuleList.Count);
    for I1 := 0 to ModuleList.Count - 1 do begin
      WriteString(TRaveModule(ModuleList[I1]).ModuleName);
      StartWriteBlock;
      TRaveModule(ModuleList[I1]).SaveToStream(StreamHelper.Stream);
      FinishWriteBlock;
    end; { for }
  end; { with }
end;  { SaveModules }

procedure TRaveModuleManager.ReleaseModule(AModule: TRaveModule);
var
  I1: integer;

  procedure ProcessProjectItem(AProjectItem: TRaveProjectItem);
  var
    I1: integer;
  begin { ProcessProjectItem }
    if Assigned(AProjectItem.Module) then begin
      AProjectItem.Module.Changing(AModule,nil);
    end; { if }
    for I1 := 0 to AProjectItem.ComponentCount - 1 do begin
      if AProjectItem.Components[I1] is TRaveProjectItem then begin
        ProcessProjectItem(TRaveProjectItem(AProjectItem.Components[I1]));
      end; { if }
    end; { for }
  end;  { ProcessProjectItem }

begin { ReleaseModule }
  if not Assigned(AModule) then Exit;
  for I1 := 0 to ModuleList.Count - 1 do begin
    TRaveModule(ModuleList[I1]).Changing(AModule,nil);
  end; { for }
  ProcessProjectItem(ProjectManager);
end;  { ReleaseModule }

{ class TRaveProjectManager }

constructor TRaveProjectManager.Create(AOwner: TComponent);
begin { Create }
  inherited Create(AOwner);

  FReportList := TList.Create;
  FGlobalPageList := TList.Create;
  FDataObjectList := TList.Create;
  FCategories := TStringList.Create;
  Params := TStringList.Create;
  FBaseReport := GBaseReport;
  FModuleManager := TRaveModuleManager.Create(self);

  Signature := {Trans-}'RAV'#26;
  UnitsFactor := ProjectUnitsFactor;
end;  { Create }

destructor TRaveProjectManager.Destroy;
begin { Destroy }
  Clear;
  FreeAndNil(FModuleManager);
  FreeAndNil(Params);
  FreeAndNil(FCategories);
  FreeAndNil(FReportList);
  FreeAndNil(FGlobalPageList);
  FreeAndNil(FDataObjectList);

  inherited Destroy;
end;  { Destroy }

procedure TRaveProjectManager.ReportToStream(AReport: TRaveReport;
                                             AStream: TStream);

var
  StreamHelper: TStreamHelper;

  procedure ClearProjectItem(ProjectItem: TRaveProjectItem);
  var
    I1: integer;
  begin { ClearProjectItem }
    ProjectItem.Included := false;
    for I1 := 0 to ProjectItem.ComponentCount - 1 do begin
      if ProjectItem.Components[I1] is TRaveProjectItem then begin
        ClearProjectItem(TRaveProjectItem(ProjectItem.Components[I1]));
      end; { if }
    end; { for }
  end;  { ClearProjectItem }

  procedure ClearProjectItems(ProjectItemList: TList);
  var
    I1: integer;
  begin { ClearProjectItems }
    for I1 := 0 to ProjectItemList.Count - 1 do begin
      ClearProjectItem(TRaveProjectItem(ProjectItemList[I1]));
    end; { for }
  end;  { ClearProjectItems }

  procedure AddProjectItems(ProjectItemList: TList);
  var
    I1: integer;
  begin { AddProjectItems }
    for I1 := 0 to ProjectItemList.Count - 1 do begin
      if TRaveProjectItem(ProjectItemList[I1]).Included then begin
        ExportList.Add(ProjectItemList[I1]);
      end; { if }
    end; { for }
  end;  { AddProjectItems }

  procedure SetIncluded(Item: TPersistent;
                        DoOwned: boolean);
  var
    Count: integer;
    PropList: PPropList;
    PropInfo: PPropInfo;
    I1: integer;
    I2: integer;
    O1: TObject;

    procedure CheckComponent(C1: TComponent);
    begin { CheckComponent }
      if Assigned(C1) then begin
        if C1 is TRaveProjectItem then begin
          if not TRaveComponentAccess(C1).UseMaster and not TRaveProjectItem(C1).Included then begin
            TRaveProjectItem(C1).Included := true;
            SetIncluded(TRaveProjectItem(C1),true);
          end; { if }
        end; { if }
      end; { if }
    end;  { CheckComponent }

  begin { SetIncluded }
    if Assigned(Item) then begin
      Count := GetTypeData(Item.ClassInfo)^.PropCount;
      if Count > 0 then begin
        GetMem(PropList,Count * SizeOf(pointer));
        try
          GetPropInfos(Item.ClassInfo,PropList);
          for I1 := 0 to (Count - 1) do begin
            PropInfo := PropList^[I1];
            if PropInfo.PropType^.Kind = tkClass then begin
              O1 := TObject(GetOrdProp(Item,PropInfo));
              if Assigned(O1) then begin
                if O1 is TComponent then begin
                  CheckComponent(TComponent(O1).Owner);
                  CheckComponent(TComponent(O1));
                end else if O1 is TPersistent then begin