rpsystem.pas

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

      if not Aborted then begin
        if ReportDest in [rdPrinter,rdFile] then begin
          if (ReportDest = rdPrinter) or DoNativeOutput then begin // Printer or Native output
            PrintReport(StatusForm);
          end else if Assigned(RenderObject) then begin // Rendered output
            PrintRender(StatusForm);
          end else begin // NDR output only
            if Assigned(FOnOverrideStatus) then begin
              FOnOverrideStatus(self,omFree,StatusForm);
            end; { if }
          end; { else }
        end else if ReportDest = rdPreview then begin
          PreviewReport(PreviewForm);
        end; { else }
      end; { if }
    finally
      if ReportStream <> nil then begin
        ReportStream.Free;
      end; { if }
      if ((ReportDest = rdPreview) or (soUseFiler in SystemOptions) or
       ForceMultiPrint) and
       (SystemFiler.StreamMode = smTempFile) then begin { Erase temp file }
        AssignFile(TempFile,SystemFiler.FileName);
        try
          Erase(TempFile);
        except
        end; { tryx }
      end; { if }
    end; { tryf }
  end; { if }
end;  { Execute }

procedure TRvSystem.SetRenderObject(const Value: TRPRender);
begin
  FRenderObject := Value;
end;

procedure TRvSystem.InitRenderStream(var RenderStream: TStream);
begin
  case SystemFiler.StreamMode of
    smMemory: begin
      RenderStream := TMemoryStream.Create;
      with RenderStream as TMemoryStream do begin
        SystemFiler.Stream.Position := 0;
        LoadFromStream(SystemFiler.Stream);
      end; { with }
    end;
    smFile,smTempFile: begin
      RenderStream := TFileStream.Create(SystemFiler.Filename,fmOpenRead or
       fmShareDenyWrite);
    end;
    smUser: begin
      if SystemFiler.Stream = nil then begin
        RaiseError(Trans('StreamMode is smUser but Stream is nil'));
      end; { if }
      RenderStream := SystemFiler.Stream;
      RenderStream.Position := 0;
    end;
  end; { case }
  RenderStream.Position := 0;
end;

procedure TRvSystem.PrintRender(var StatusForm: TForm);
var
  NDRStream: TStream;
begin
//!!! Add calls to OnOverrideStatus similar to PrintReport
  if Assigned(FOnOverrideStatus) and Assigned(StatusForm) then begin
    FOnOverrideStatus(self,omFree,StatusForm);
  end; { if }
  NDRStream := nil;
  try
    InitRenderStream(NDRStream);
    RenderObject.OutputFileName := OutputFileName;
    RenderObject.Render(NDRStream);
  finally
    if SystemFiler.StreamMode <> smUser then begin
      FreeAndNil(NDRStream);
    end; { if }
  end;
end;

{ class TSystemPrinter }

constructor TSystemPrinter.Create;
begin { Create }
  inherited Create;

  FCopies := 1;
  FFirstPage := 1;
  FLastPage := 9999;
  FLineHeightMethod := lhmFont;
  FLinesPerInch := 6;
  FMarginBottom := 0.0;
  FMarginLeft := 0.0;
  FMarginRight := 0.0;
  FMarginTop := 0.0;
  FOrientation := poPortrait;
  FScaleX := 100.0;
  FScaleY := 100.0;
  FStatusFormat := Trans('Printing page %p');
  FStatusText := TStringList.Create;
  FTabShade := 0;
  FTextBKMode := bkTransparent;
  FTitle := Trans('ReportPrinter Report');
  FUnits := unInch;
  FUnitsFactor := 1.0;
  FCollate := false;
  FDuplex := GlobalDevice.Duplex;
end;  { Create }

destructor TSystemPrinter.Destroy;
begin { Destroy }
  FreeAndNil(FStatusText);

  inherited Destroy;
end;  { Destroy }

procedure TSystemPrinter.SetStatusText(Value: TStrings);
begin { SetStatusText }
  FStatusText.Assign(Value);
end;  { SetStatusText }

procedure TSystemPrinter.SetTabShade(Value: integer);
begin { SetTabShade }
  if Value >= 100 then begin
    FTabShade := 100;
  end else if Value <= 0 then begin
    FTabShade := 0;
  end else begin
    FTabShade := Value;
  end; { else }
end;  { SetTabShade }

procedure TSystemPrinter.SetUnits(Value: TPrintUnits);
begin { SetUnits }
  FUnits := Value;
  case FUnits of
    unInch: begin
      FUnitsFactor := 1.0;
    end;
    unMM: begin
      FUnitsFactor := 25.4;
    end;
    unCM: begin
      FUnitsFactor := 2.54;
    end;
    unPoint: begin
      FUnitsFactor := 72.0;
    end;
    unUser: begin
    { Don't change FUnitsFactor }
    end;
  end; { case }
end;  { SetUnits }

procedure TSystemPrinter.SetUnitsFactor(Value: double);
var
  R1: array [1..4] of double;
begin { SetUnitsFactor }
  if Value > 0.0 then begin
    FUnitsFactor := Value;
    R1[1] := 1.0;
    R1[2] := 25.4;
    R1[3] := 2.54;
    R1[4] := 72.0;
    if (FUnitsFactor = R1[1]) then begin
      FUnits := unInch;
    end else if (FUnitsFactor = R1[2]) then begin
      FUnits := unMM;
    end else if (FUnitsFactor = R1[3]) then begin
      FUnits := unCM;
    end else if (FUnitsFactor = R1[4]) then begin
      FUnits := unPoint;
    end else begin
      FUnits := unUser;
    end; { else }
  end; { if }
end;  { SetUnitsFactor }

procedure TSystemPrinter.InitPrinter(BaseReport: TBaseReport);
begin { InitPrinter }
  with BaseReport do begin
    Copies := FCopies;
    FirstPage := FFirstPage;
    LastPage := FLastPage;
    LineHeightMethod := FLineHeightMethod;
    LinesPerInch := FLinesPerInch;
    MarginBottom := FMarginBottom;
    MarginLeft := FMarginLeft;
    MarginRight := FMarginRight;
    MarginTop := FMarginTop;
    Orientation := FOrientation;
    ScaleX := FScaleX;
    ScaleY := FScaleY;
    StatusFormat := FStatusFormat;
    StatusText := FStatusText;
    TabShade := FTabShade;
    TextBKMode := FTextBKMode;
    Title := FTitle;
    Units := FUnits;
    if FUnits = unUser then begin
      UnitsFactor := FUnitsFactor;
    end; { if }
    if (RPDev = nil) or not RPDev.InvalidPrinter then begin
      Collate := FCollate;
      Duplex := FDuplex;
    end; { if }
  end; { with }
end;  { InitPrinter }

{ class TSystemPreview }

constructor TSystemPreview.Create;
begin { Create }
  inherited Create;

  FFormWidth := 615;
  FFormHeight := 450;
  FFormState := wsNormal;
  FGridHoriz := 0.0;
  FGridPen := TPen.Create;
  FGridVert := 0.0;
  FMarginMethod := mmFixed;
  FMarginPercent := 0.0;
  FMonochrome := false;
  FRulerType := rtNone;
  FShadowDepth := 0;
  FZoomFactor := 100.0;
  FZoomInc := 10;
  FPagesWide := 1;
  FPagesHigh := 1;
  FPageInc := 1;
end;  { Create }

destructor TSystemPreview.Destroy;
begin { Destroy }
  FreeAndNil(FGridPen);

  inherited Destroy;
end;  { Destroy }

procedure TSystemPreview.SetMonochrome(Value: boolean);
begin { SetMonochrome }
  if (ShadowDepth > 0) and Value then begin { Warn programmer }
    ShowMessage({Trans-}'Monochrome not allowed while shadows are in effect.'#13 +
     {Trans-}'Change ShadowDepth to 0 first');
  end else begin
    FMonochrome := Value;
  end; { else }
end;  { SetMonochrome }

procedure TSystemPreview.SetShadowDepth(Value: integer);
begin { SetShadowDepth }
  if (Value > 0) and Monochrome then begin { Warn programmer }
    ShowMessage({Trans-}'Shadows not allowed while monochrome in effect.'#13 +
     {Trans-}'Change Monochrome to false first');
  end else begin
    FShadowDepth := Value;
  end; { else }
end;  { SetShadowDepth }

procedure TSystemPreview.SetZoomFactor(Value: double);
begin { SetZoomFactor }
  if Value < 10.0 then begin
    FZoomFactor := 10.0;
  end else if Value > 200.0 then begin
    FZoomFactor := 200.0;
  end else begin
    FZoomFactor := Value;
  end; { else }
end;  { SetZoomFactor }

procedure TSystemPreview.InitPreview(RenderPreview: TRvRenderPreview);
begin { InitPreview }
  with RenderPreview as TRvRenderPreview do begin
      GridHoriz := FGridHoriz;
      GridPen := FGridPen;
      GridVert := FGridVert;
      MarginMethod := FMarginMethod;
      MarginPercent := FMarginPercent;
      ShadowDepth := FShadowDepth; // Must be set before Monochrome
      Monochrome := FMonochrome;
      PagesWide := FPagesWide;
      PagesHigh := FPagesHigh;
      PageInc := FPageInc;
      RulerType := FRulerType;
      ZoomFactor := FZoomFactor;
      ZoomInc := FZoomInc;
    end; { with }
end;  { InitPreview }

{ class TSystemFiler }

constructor TSystemFiler.Create;
begin { Create }
  inherited Create;

  FAccuracyMethod := amPositioning;
  FFileName := '';
  FStatusFormat := Trans('Generating page %p');
  FStatusText := TStringList.Create;
  FStreamMode := smMemory;
  FStream := nil;
end;  { Create }

destructor TSystemFiler.Destroy;
begin { Destroy }
  FreeAndNil(FStatusText);

  inherited Destroy;
end;  { Destroy }

procedure TSystemFiler.SetStatusText(Value: TStrings);
begin { SetStatusText }
  FStatusText.Assign(Value);
end;  { SetStatusText }

procedure TSystemFiler.InitFiler(BaseReport: TBaseReport);
begin { InitFiler }
  BaseReport.IgnoreRPTF := IgnoreRPTF;
  if BaseReport is TRvNDRWriter then begin
    with BaseReport as TRvNDRWriter do begin
      AccuracyMethod := FAccuracyMethod;
      FileName := FFileName;
      StatusFormat := FStatusFormat;
      StatusText := FStatusText;
      if FStreamMode = smMemory then begin
        StreamMode := smUser;
        FStream := TMemoryStream.Create;
      end else begin
        StreamMode := FStreamMode;
      end; { else }
      Stream := FStream;
    end; { with }
(*!!PORT!!
  end else if BaseReport is TRvNDRPrinter then begin
    With BaseReport as TRvNDRPrinter do begin
      FileName := FFileName;
      If FStreamMode = smMemory then begin
        StreamMode := smUser;
      end else begin
        StreamMode := FStreamMode;
      end; { else }
      Stream := FStream;
    end; { with }
*)
  end; { else }
end;  { InitFiler }

end.