sctrtf.pas

suite component ace report

unit SctRtf;

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


interface
{$I ace.inc}

{$IFDEF WIN32}
uses classes, sysutils, graphics, windows, psetup;
{$ELSE}
uses classes, sysutils, graphics, winprocs, wintypes, psetup;
{$ENDIF}
{$B-}

type
  TSctRtfFile = class;

  TSctRtfBorderType = (rbtBox, rbtBottom);

{ TSctRtfFont }
  TSctRtfFont = class(TObject)
  private
    FNumber: Integer;
    FPitchAndFamily, FCharSet: Byte;
    FName: String;
    FFont: TFont;
  protected
    procedure SetFont(f: TFont); virtual;
  public
    constructor Create; virtual;
    destructor Destroy; override;
    procedure Assign(f: TObject); virtual;

    property Number: Integer read FNumber write FNumber;
    property PitchAndFamily: Byte read FPitchAndFamily write FPitchAndFamily;
    property CharSet: Byte read FCharSet write FCharSet;
    property Name: String read FName write FName;
    property Font: TFont read FFont write SetFont;

    procedure WriteFont(RtfFile: TSctRtfFile);
    function FontSame(f: TFont): Boolean; virtual;
    function DefinitionSame(f: TFont): Boolean; virtual;
    procedure WriteHeader(Stream: TStream); virtual;
  end;

{ TSctTabAlignment }
  TSctTabAlignment = (taLeft, taCenter, taRight);

{ TSctRtfFile }
  TSctRtfFile = class(TObject)
  private
    FWriteStream, FStream: TStream;
    FFont: TFont;
    FRtfFont: TSctRtfFont;
    FFontList: TList;
    FBraceCount: LongInt;
    FPageSetup: TSctPageSetup;
    FBorder: Boolean;
    FBorderType: TSctRtfBorderType;
    FPageBreak: Boolean;
  protected
    procedure SetRtfFont(f: TSctRtfFont); virtual;
    procedure SetFont(f: TFont);
    procedure SetPageSetup(ps: TSctPageSetup);
  public
    constructor Create(FileName: String); virtual;
    destructor Destroy; override;

    procedure AddFont(f: TSctRtfFont); virtual;
    procedure StartBorder; virtual;
    procedure EndBorder; virtual;
    procedure TextOut(Text: String); virtual;
    procedure TextOutStream(s: TStream); virtual;
    property Stream: TStream read FStream write FStream;
    property WriteStream: TStream read FWriteStream write FWriteStream;
    procedure WriteFile; virtual;
    procedure Write(Text: String);
    procedure NewParagraph; virtual;
    property FontList: TList read FFontList write FFontList;
    property RtfFont: TSctRtfFont read FRtfFont write SetRtfFont;
    property Font: TFont read FFont write SetFont;

    procedure StartFrame(x,y,w,h: Integer);
    procedure EndFrame;
    procedure ParagraphDefault;
    procedure PushBrace; virtual;
    procedure PopBrace; virtual;
    property BraceCount: LongInt read FBraceCount write FBraceCount;
    procedure DefineTab(xPos: Integer; t: TSctTabAlignment); virtual;
    procedure Tab; virtual;
    property PageSetup: TSctPageSetup read FPageSetup write SetPageSetup;
    property Border: Boolean read FBorder write FBorder;
    property BorderType: TSctRtfBorderType read FBorderType write FBorderType;
    property PageBreak: Boolean read FPageBreak write FPageBreak;
  end;

implementation

uses aceutil, dialogs;

procedure SendStream(Stream: TStream; text: String);
var
  str: array[0..256] of Char;
begin
  StrPCopy(str, text);
  Stream.Write(str, Length(text));
end;

{ TSctRtfFont }
constructor TSctRtfFont.Create;
begin
  inherited Create;
  FFont := TFont.Create;
end;

destructor TSctRtfFont.Destroy;
begin

  if FFont <> nil then FFont.free;
  inherited destroy;
end;

procedure TSctRtfFont.Assign(f: TObject);
begin
  if f is TSctRtfFont then Font := TSctRtfFont(f).Font;
end;

procedure TSctRtfFont.SetFont(f: TFont);
var
  LogRec: TLOGFONT;
begin
  FFont.Assign(f);
  AceGetObject(FFont.Handle,SizeOf(LogRec),Addr(LogRec));

  PitchAndFamily := LogRec.lfPitchAndFamily;
  CharSet := LogRec.lfCharSet;
  Name := StrPas(LogRec.lfFaceName);
end;

procedure TSctRtfFont.WriteFont(rtfFile: TSctRtfFile);
begin
  rtfFile.Write('\f' + AceIntToStr(Number));
  rtfFile.Write('\fs' + AceIntToStr(Font.Size * 2));
  if fsBold in Font.Style then rtfFile.Write('\b');
  if fsItalic in Font.Style then rtfFile.Write('\i');
  if fsUnderline in Font.Style then rtfFile.Write('\ul');
{  if fsStrikeOut in Font.Style then rtfFile.Write('\so');}
  rtfFile.Write(' ');
end;

procedure TSctRtfFont.WriteHeader(stream: TStream);
var
  pitch: Integer;
  family: String;
  fam: Byte;
begin
  SendStream(Stream, '{\f' + AceIntToStr(Number));

  fam := PitchAndFamily And (15 shl 4);
  case fam of
    FF_DONTCARE: family := 'nil';
    FF_ROMAN: family := 'roman';
    FF_SWISS: family := 'swiss';
    FF_MODERN: family := 'modern';
    FF_SCRIPT: family := 'script';
    FF_DECORATIVE: family := 'decor';
  else
    family := 'nil';
  end;
  SendStream(Stream, '\f' + family);

  SendStream(Stream, '\fcharset0');

  Pitch := 0;
  case font.Pitch of
    fpDefault: Pitch := 0;
    fpFixed: Pitch := 1;
    fpVariable: Pitch := 2;
  end;
  SendStream(Stream, '\fprq' + AceIntToStr(Pitch));

  SendStream(Stream, ' ' + name + ';}');
end;

function TSctRtfFont.FontSame(f: TFont): Boolean;
var
  LogRec: TLOGFONT;
begin
  result := True;

  if Font.Style <> f.style then result := False
  else if Font.Size <> f.size then result := False
  else if Font.Color <> f.color then result := False
  else if Font.Pitch <> f.Pitch then result := False
  else if Font.Name <> f.Name then result := False
  else
  begin
    AceGetObject(FFont.Handle,SizeOf(LogRec),Addr(LogRec));
    if PitchAndFamily <> LogRec.lfPitchAndFamily then result := False
    else if CharSet <> LogRec.lfCharSet then result := False;
  end;
end;

function TSctRtfFont.DefinitionSame(f: TFont): Boolean;
var
  LogRec: TLOGFONT;
begin
  result := True;

  if Font.Pitch <> f.Pitch then result := False
  else if Font.Name <> f.Name then result := False
  else
  begin
    AceGetObject(FFont.Handle,SizeOf(LogRec),Addr(LogRec));
    if PitchAndFamily <> LogRec.lfPitchAndFamily then result := False
    else if CharSet <> LogRec.lfCharSet then result := False;
  end;
end;


{ TSctRtfFile }
constructor TSctRtfFile.Create(filename: String);
begin
  inherited create;
  FPageBreak := False;
  FBorder := False;
  FPageSetup := TSctPageSetup.Create;
  FBraceCount := 0;
  FFontList :=  TList.Create;
  FRtfFont := TSctRtfFont.Create;
  AddFont(FRtfFont);
  FFont := TFont.Create;
  FRtfFont.Font := FFont;

  FWriteStream := TFileStream.Create(filename, fmCreate);
  FStream := TMemoryStream.Create;

  Write('\pard\plain ');
  RtfFont.WriteFont(self);
end;

destructor TSctRtfFile.Destroy;
var
  pos: Integer;
begin
  while BraceCount > 0 do
  begin
    BraceCount := BraceCount - 1;
    Write('}');
  end;
  Write('}');
  WriteFile;
  if FPageSetup <> nil then FPageSetup.Free;
  if FStream <> nil then FStream.Free;
  if FWriteStream <> nil then FWriteStream.Free;

  if FFontList <> nil then
  begin
    for pos := 0 to FFontList.Count - 1 do
    begin
      TSctRtfFont(FFontList.items[pos]).Free;
    end;
    FFontList.Free;
  end;
  if FFont <> nil then FFont.Free;
  inherited destroy;
end;

procedure TSctRtfFile.SetPageSetup(ps: TSctPageSetup);
begin
  FPageSetup.Assign(ps);
end;

procedure TSctRtfFile.SetRtfFont(f: TSctRtfFont);
begin
  FRtfFont := f;
end;

procedure TSctRtfFile.SetFont(f: TFont);
var
  pos: Integer;
  spot: Integer;
begin
  if Not RtfFont.FontSame(f) then
  begin
    { find if any of the other fonts are the same }
    pos := 0;
    spot := -1;
    while (spot = -1) And (pos < FontList.Count) do
    begin
      if TSctRtfFont(FontList.items[pos]).DefinitionSame(f) then spot := pos;
      Inc(pos);
    end;
    if spot = -1 then
    begin
      AddFont( TSctRtfFont.Create );
    end else RtfFont := TSctRtfFont(FontList.items[spot]);
    FFont.Assign(f);
    RtfFont.Font := f;

    PopBrace;
    PushBrace;
    RtfFont.WriteFont(self);
  end;
end;

procedure TSctRtfFile.PushBrace;
begin
  BraceCount := BraceCount + 1;
  Write('{');
end;

procedure TSctRtfFile.PopBrace;
begin
  if BraceCount > 0 then
  begin
    BraceCount := BraceCount - 1;
    Write('}');
  end;
end;

procedure TSctRtfFile.AddFont(f: TSctRtfFont);
begin
  FontList.Add(f);
  f.Number := FontList.Count;
  RtfFont := f;
end;

procedure TSctRtfFile.Write(text: String);
begin
  SendStream(Stream, text);
end;

procedure TSctRtfFile.WriteFile;
var
  pos: Integer;

  function AceRoundToStr(Value: Extended): String;
  var
    Error: Boolean;
    IntVal: LongInt;
  begin
    Error := False;
    if Value = 0 then Error := True
    else
    begin
      IntVal := Round(Value);
      if IntVal = 0 then Error := True
      else
      begin
        Result := AceIntToStr(IntVal);
      end;
    end;
    if Error then
    begin
{      ShowMessage('Value: ' + FloatToStr(Value));
      ShowMessage('Width: ' + FloatToStr(PageSetup.Width));
      ShowMessage('Height: ' + FloatToStr(PageSetup.Height));}
    end;
  end;
begin
  SendStream(WriteStream, '{\rtf1\ansi ');
  SendStream(WriteStream, '{\fonttbl');
  for pos := 0 to FontList.Count - 1 do TSctRtfFont(FontList.items[pos]).WriteHeader(WriteStream);
  SendStream(WriteStream, '}');

  case PageSetup.Size of
    psUseCurrent:;
    psCustom:
    begin
      SendStream(WriteStream, '\paperw' + AceIntToStr(round(PageSetup.Width * 1440)) );
      SendStream(WriteStream, '\paperh' + AceIntToStr(round(PageSetup.Height * 1440)) );
      SendStream(WriteStream, '\psz' + AceIntToStr(PageSetup.AcePrinterSetup.PaperSize ));
    end;
    else
    begin
      SendStream(WriteStream, '\paperh' + AceRoundToStr(PageSetup.Height * 1440));
      SendStream(WriteStream, '\paperw' + AceRoundToStr(PageSetup.Width * 1440));
      SendStream(WriteStream, '\psz' + AceIntToStr(PageSetup.AcePrinterSetup.PaperSize));
    end;
  end;

  SendStream(WriteStream, '\margl' + AceRoundToStr(PageSetup.LeftMargin * 1440));
  SendStream(WriteStream, '\margr' + AceRoundToStr(PageSetup.RightMargin * 1440));
  SendStream(WriteStream, '\margt' + AceRoundToStr(PageSetup.TopMargin * 1440) );
  SendStream(WriteStream, '\margb' + AceRoundToStr(PageSetup.BottomMargin * 1440));
  if PageSetup.Orientation = poLandScape then SendStream(WriteStream, '\landscape');




  SendStream(WriteStream, ' ');

  Stream.Position := 0;
  WriteStream.CopyFrom( Stream, Stream.Size );

end;

procedure TSctRtfFile.StartBorder;
begin
  Border := True;
end;

procedure TSctRtfFile.EndBorder;
begin
  Border := False;
  if BorderType <> rbtBottom then
  begin
   ParagraphDefault;
   NewParagraph;
  end;
end;

procedure TsctRtfFile.NewParagraph;
begin
  Write('\par ');
end;

procedure TSctRtfFile.ParagraphDefault;
begin
  PopBrace;
  Write('\pard');
  if FPageBreak then Write(' \page');
  if Border then
  begin
    case BorderType of
      rbtBottom: Write('\brdrb\brdrs ');
      rbtBox: Write('\box\brdrs ');
    end;
  end;
  RtfFont := fontlist.items[0];
  RtfFont.WriteFont(self);
end;

procedure TSctRtfFile.StartFrame(x,y,w,h: Integer);
begin
  ParagraphDefault;
  Write('\posyt\phmrg');
  Write('\posx' + AceIntToStr(x));
  Write('\posy' + AceIntToStr(y));
  if w > 0 then Write('\absw' + AceIntToStr(w));
  if h > 0 then Write('\absh' + AceIntToStr(h));
  Write('\dxfrtext180\dfrmtxtx180\dfrmtxty0 ');
end;

procedure TsctRtfFile.EndFrame;
begin
  NewParagraph;
  ParagraphDefault;
end;

procedure TSctRtfFile.TextOut(text: String);
begin
  Write(text);
end;

procedure TSctRtfFile.TextOutStream(s: TStream);
begin
  s.Position := 0;
  Stream.CopyFrom( S, S.Size );
end;

procedure TSctRtfFile.DefineTab(xPos: Integer; t: TSctTabAlignment);
begin
  case t of
    taLeft:;
    taCenter: Write('\tqc');
    taRight: Write('\tqr');
  end;
  Write('\tx' + AceIntToStr(xPos) + ' ');
end;

procedure TSctRtfFile.Tab;
begin
  Write('\tab ');
end;


end.