acertfp.pas

来自「suite component ace report」· PAS 代码 · 共 288 行

unit AceRtfP;

{ ----------------------------------------------------------------
  Ace Reporter
  Copyright 1995-1998 SCT Associates, Inc.
  Written by Kevin Maher, Steve Tyrakowski
  ---------------------------------------------------------------- }

interface
{$I ace.inc}

uses windows, classes, comctrls, richedit, sysutils, graphics;

type
  TAceRtfDraw = class(TObject)
  private
    FRichEdit: TRichEdit;
    FPosition: LongInt;
    FOutRect: TRect;
    FHandle: THandle;
    FTextLength: LongInt;
    FPixelsPerInchX, FPixelsPerInchY: Integer;
    FRangeStart, FRangeEnd: LongInt;
    FPrintCount, FHeight: LongInt;
    FFont: TFont;

    function GetHeight: LongInt;
    function GetTextLength: LongInt;
    function ScaleRect(Rect: TRect; Handle: THandle): TRect;
    function PScaleRect(Rect: TRect; Handle: THandle): TRect;
    procedure SetHandle(hnd: THandle);
    procedure SetPosition(Value: LongInt);
    procedure SetCountHeight;
    function GetPrintCount: LongInt;

  protected
    procedure SetFont(F: TFont);
  public
    SetDefaultFont: Boolean;

    constructor Create; virtual;
    destructor Destroy; override;

    procedure LoadFromStream(Stream: TStream);
    procedure Print;
    procedure Reset;

    property PrintCount: LongInt read GetPrintCount write FPrintCount;
    property RichEdit: TRichEdit read FRichEdit write FRichEdit;
    property OutRect: TRect read FOutRect write FOutRect;
    property Handle: THandle read FHandle write SetHandle;
    property Height: LongInt read GetHeight;
    property TextLength: LongInt read GetTextLength;
    property PixelsPerInchX: Integer read FPixelsPerInchX write FPixelsPerInchX;
    property PixelsPerInchY: Integer read FPixelsPerInchY write FPixelsPerInchY;
    property Position: LongInt read FPosition write SetPosition;
    property RangeStart: LongInt read FRangeStart write FRangeStart;
    property RangeEnd: LongInt read FRangeEnd write FRangeEnd;

    property Font: TFont read FFont write SetFont;
  end;


implementation

uses aceutil, acememou, printers, forms, messages;

function MyScaleRect(Rect: TRect; InX,InY,OutX,OutY: Integer): TRect;
var
  w,h: Integer;
begin
  w := MulDiv(Rect.Right - Rect.Left + 1, OutX, InX);
  h := MulDiv(Rect.Bottom - Rect.Top + 1, OutY, InY);

  Rect.Left := MulDiv(Rect.Left, OutX, InX);
  Rect.Top := MulDiv(Rect.Top, OutY, InY);

  Rect.Right := Rect.Left + w - 1;
  Rect.Bottom := Rect.Top + h - 1;

  Result := Rect;
end;
function RectToTwips(Rect: TRect; px,py: Integer): TRect;
begin
  Result := MyScaleRect(Rect, px,py,1440,1440);
end;


constructor TAceRtfDraw.Create;
begin
  FFont := TFont.Create;

  FRichEdit := TRichEdit.Create(nil);
  FRichEdit.Parent := GForm;
  FRichEdit.Height := 500;
  FRichEdit.Width := 500;
  Reset;
end;
destructor TAceRtfDraw.Destroy;
begin
  if FRichEdit <> nil then
  begin
    FRichEdit.Parent := nil;
    FRichEdit.Free;
  end;
  if FFont <> nil then FFont.Free;
  inherited Destroy;
end;
procedure TAceRtfDraw.SetFont(F: TFont);
begin
  FFont.Assign(F);
end;

procedure TAceRtfDraw.Reset;
begin
  FPosition := 0;
  FHandle := 0;
  FTextLength := 0;
  FRichEdit.Lines.Clear;
  FPixelsPerInchX := 0;
  FPixelsPerInchY := 0;
  FRangeStart := -1;
  FRangeEnd := -1;

  FPrintCount := 0;
  FHeight := 0;
  SetDefaultFont := False;
end;

function TAceRtfDraw.GetTextLength: LongInt;
begin
  if FTextLength = 0 then FTextLength := FRichEdit.GetTextLen;
  Result := FTextLength;
end;
procedure TAceRtfDraw.SetPosition(Value: LongInt);
begin
  FPosition := Value;
  FPrintCount := 0;
  FHeight := 0;
end;
procedure TAceRtfDraw.LoadFromStream(Stream: TStream);
begin
  FRichEdit.Lines.Clear;
  Stream.Position := 0;
  FRichEdit.Lines.LoadFromStream(Stream);
  FHeight := 0;
  FTextLength := 0;
  FPrintCount := 0;
  GetTextLength;
end;
function TAceRtfDraw.ScaleRect(Rect: TRect; Handle: THandle): TRect;
begin
  Result := RectToTwips(Rect, PixelsPerInchX, PixelsPerInchY);
end;
function TAceRtfDraw.PScaleRect(Rect: TRect; Handle: THandle): TRect;
var
  px,py, HRes, VRes: Integer;
begin
  if AceIsScreen(Handle) then
  begin
    px := GetDeviceCaps(Handle, LOGPIXELSX);
    py := GetDeviceCaps(Handle, LOGPIXELSY);
    if (PixelsPerInchX <> px) or (PixelsPerInchY <> py) then
    begin

      HRes := GetDeviceCaps(Handle, HORZRES);
      VRes := GetDeviceCaps(Handle, VERTRES);
      SetMapMode(Handle, MM_ANISOTROPIC);
      SetWindowExtEx(Handle, HRes, VRes, nil);
      SetViewPortExtEx(Handle, MulDiv(HRes, PixelsPerInchX, px), MulDiv(VRes, PixelsPerInchX, px), nil);

    end;
  end;
  Result := RectToTwips(Rect, PixelsPerInchX, PixelsPerInchY);
end;
procedure TAceRtfDraw.SetHandle(hnd: THandle);
begin
  FHandle := hnd;
end;
function TAceRtfDraw.GetHeight: LongInt;
begin
  if FHeight = 0 then SetCountHeight;
  Result := FHeight;
end;
function TAceRtfDraw.GetPrintCount: LongInt;
begin
  if FPrintCount = 0 then SetCountHeight;
  Result := FPrintCount;
end;
procedure TAceRtfDraw.SetCountHeight;
var
  Range: TFormatRange;
  Bottom, CurrentBottom: LongInt;
begin
  if (FPosition < FTextLength) then
  begin
{    FRichEdit.Font := Font;}
    if SetDefaultFont then FRichEdit.DefAttributes.Assign(Font);
    FillChar(Range, SizeOf(TFormatRange), 0);
    with Range do
    begin
      hdc := Printers.Printer.Handle;
      hdcTarget := hdc;
      rc := ScaleRect(FOutRect, hdc);
      rcPage := rc;

      bottom := rc.Bottom;
      chrg.cpMax := FRangeEnd;
      if FRangeStart > FPosition then chrg.cpMin := FRangeStart
      else chrg.cpMin := FPosition;

      SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, 0);
      try
        FPrintCount := SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, Longint(@Range));
        CurrentBottom := rc.Bottom;
        while Bottom < rc.Bottom do
        begin
          SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, 0);
          CurrentBottom := CurrentBottom - 140;
          rc.Bottom := CurrentBottom;
          FPrintCount := SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, Longint(@Range));
        end;
        FPrintCount := FPrintCount - chrg.cpMin;
      finally
        FHeight := MulDiv(rc.Bottom - rc.Top + 1, PixelsPerInchY, 1440);
        if FHeight > (FOutRect.Bottom - FOutRect.Top - 1) then
        begin
          FHeight := FOutRect.Bottom - FOutRect.Top - 1;
        end;
        SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, 0);
      end;
    end;
  end;
end;

procedure TAceRtfDraw.Print;
var
  Range: TFormatRange;
  SDC: THandle;
begin
  if (FHandle <> 0) And (FPosition < FTextLength) then
  begin
    SDC := SaveDC(FHandle);
    try
{      FRichEdit.Font := Font;}
      if SetDefaultFont then FRichEdit.DefAttributes.Assign(Font);
      FillChar(Range, SizeOf(TFormatRange), 0);
      with Range do
      begin
        hdc := FHandle;
        hdcTarget := hdc;
        rc := PScaleRect(FOutRect, hdc);
        rcPage := rc;

        if Not AceIsScreen(hdc) then
        begin
          SetMapMode(hdc, MM_TEXT);
          { always make sure everything prints to the printer }
          rc.Bottom := rc.Bottom + 5000;
        end;

        chrg.cpMax := FRangeEnd;
        if FRangeStart > FPosition then chrg.cpMin := FRangeStart
        else chrg.cpMin := FPosition;
        SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, 0);
        try
        { do some scaling here if the rc.Bottom exceeds its value when going to
          screen only.  This is form when the preview is zoomed and the rtf text
          may need to be scaled differently.  This should be the only left to do.}
{          if AceIsScreen(hdc) then}

          FPosition := SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 1, Longint(@Range));
        finally
          SendMessage(FRichEdit.Handle, EM_FORMATRANGE, 0, 0);
          FHeight := 0;
          FPrintCount := 0;
        end;
      end;
    finally
      RestoreDC(FHandle, SDC);
    end;
  end;
end;



end.