acememou.pas

suite component ace report

unit AceMemoU;

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

interface
{$I ace.inc}
uses
  {$IFDEF WIN32}
    windows,
  {$ELSE}
    winprocs,wintypes,
  {$ENDIF}
  SysUtils, Messages, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls, AceOut;

type
  TAceMemoAlignment = (maLeft, maCenter, maRight, maJustify);

  TAceMemo = class (TObject)
  private
    FPixelsPerInch: Integer;
    FFont: TFont;
    FWidth: Integer;
    FWrapHeightPercent: Integer;
    FWrapText: Boolean;
    FJustifyLastLine: Boolean;
    FCarriageReturnList: TList;
    FMemoStrings: TStringList;
    FMemoLines: Integer;
    FMemoStream: TStream;
    FMemoAlignment: TAceMemoAlignment;
    FLineHeight: Integer;
    FParts: TList;
    FRangeBegin, FRangeEnd: Integer;
    FTextLen: Integer;
    FTextDriverCompatibility: Boolean;
    FSuppressBlankLines: Boolean;
    FSuppressWhiteSpace: Boolean;
  protected
    procedure SetFont(F: TFont); virtual;
    procedure SetMemoStream(Stream: TStream);
    property CarriageReturnList: TList read FCarriageReturnList write FCarriageReturnList;
    procedure FindCarriageReturns;
    function GetPrintHeight: Integer;
  public
    constructor Create; virtual;
    destructor Destroy; override;

    procedure UpdateMemo;

    property Parts: TList read FParts write FParts;
    property RangeBegin: Integer read FRangeBegin write FRangeBegin;
    property RangeEnd: Integer read FRangeEnd write FRangeEnd;
    property PixelsPerInch: Integer read FPixelsPerInch write FPixelsPerInch;
    property Font: TFont read FFont write SetFont;
    property Width: Integer read FWidth write FWidth;
    property WrapHeightPercent: Integer read FWrapHeightPercent write FWrapHeightPercent;
    property WrapText: Boolean read FWrapText write FWrapText;
    property JustifyLastLine: Boolean read FJustifyLastLine write FJustifyLastLine;
    property MemoStrings: TStringList read FMemoStrings write FMemoStrings;
    property MemoLines: Integer read FMemoLines write FMemoLines;
    property MemoStream: TStream read FMemoStream write SetMemoStream;
    property MemoAlignment: TAceMemoAlignment read FMemoAlignment write FMemoAlignment;
    property LineHeight: Integer read FLineHeight write FLineHeight;
    procedure ClearParts;
    procedure ParseString(S: String);
    procedure PrintLine(AceCanvas: TAceCanvas; Text: String;
                               Rect: TRect; Spot: Integer);

    procedure Print(AceCanvas:TAceCanvas; x,y:Integer);
    property PrintHeight: Integer read GetPrintHeight;
    property TextDriverCompatibility: Boolean read FTextDriverCompatibility write FTextDriverCompatibility;
    property SuppressBlankLines: Boolean read FSuppressBlankLines write FSuppressBlankLines;
    property SuppressWhiteSpace: Boolean read FSuppressWhiteSpace write FSuppressWhiteSpace;
  end;


  TAceTabStringPos = class(TObject)
  public
    Pos: Integer;
    Text: String;
    Width: Integer;
  end;

var
  GForm: TForm;
  GMemo: TMemo;

implementation

uses printers, acesetup;

{------------------------------------------------------------------------------}
{  TAceMemo Class Implementation.                                              }
{------------------------------------------------------------------------------}
constructor TAceMemo.Create;
begin
  inherited Create;

  FPixelsPerInch := Screen.PixelsPerInch;
  FFont := TFont.Create;
  FWidth := FPixelsPerInch;
  FWrapHeightPercent := 100;
  FWrapText := True;
  FCarriageReturnList := TList.Create;
  fMemoStrings := TStringList.Create;
  FMemoLines := 0;
  FJustifyLastLine := False;
  FMemoStream := TMemoryStream.Create;
  FMemoAlignment := maLeft;
  FLineHeight := 10;

  FParts := TList.Create;
  FRangeBegin := -1;
  FRangeEnd := -1;

  FTextDriverCompatibility := False;
  FSuppressBlankLines := False;
  FSuppressWhiteSpace := False;
end;

destructor TAceMemo.Destroy;
begin
  if FFont <> nil then FFont.Free;
  if FCarriageReturnList <> nil then CarriageReturnList.Free;
  if FMemoStrings <> nil then MemoStrings.Free;
  if FMemoStream <> nil then FMemoStream.free;

  ClearParts;
  if FParts <> nil then FParts.Free;

  inherited Destroy;
end;

procedure TAceMemo.SetFont( F: TFont );
begin
  FFont.Assign(F);
end;

procedure TAceMemo.SetMemoStream(Stream: TStream);
begin
  TMemoryStream(FMemoStream).Clear;
  FMemoStream.CopyFrom(Stream, 0);
end;

procedure TAceMemo.UpdateMemo;
var
  Metrics: TTextMetric;
  FontSize: Integer;
  Spot, MySpot: Integer;
  setup: TAcePrinterSetup;

  procedure DeleteCR(CRSpot: Integer);
  begin
    MySpot := 0;
    while MySpot < FCarriageReturnList.Count do
    begin
      if CRSpot <= Integer(FCarriageReturnList.Items[MySpot]) then
      begin
        if CRSpot = Integer(FCarriageReturnList.Items[MySpot]) then
        begin
          FCarriageReturnList.Delete(MySpot);
        end;
        while MySpot < FCarriageReturnList.Count do
        begin
          FCarriageReturnList.Items[MySpot] :=
            Pointer(Integer(FCarriageReturnList.Items[MySpot])-1);
          Inc(MySpot);  
        end;
      end else Inc(MySpot);
    end;
  end;
begin
  FMemoStrings.Clear;
  FMemoLines := 0;
  setup := TAcePrinterSetup.Create;
{  if setup.PrinterCount > 0 then
    GForm.Canvas.Handle := Printers.Printer.Handle;}
  setup.free;

  GForm.PixelsPerInch := FPixelsPerInch;
  GForm.Font := FFont;
  FontSize := FFont.Size;
  GForm.Font.PixelsPerInch := FPixelsPerInch;
  GForm.Font.Size := FontSize;

  GForm.Canvas.Font := FFont;
  FontSize := FFont.Size;
  GForm.Canvas.Font.PixelsPerInch := FPixelsPerInch;
  GForm.Canvas.Font.Size := FontSize;

  GetTextMetrics( GForm.Canvas.Handle, Metrics );
  FLineHeight := abs( Metrics.tmHeight );
  FLineHeight := MulDiv( FLineHeight, FWrapHeightPercent, 100 );

  GMemo.Font := FFont;
  GMemo.Width := FWidth;
  GMemo.WordWrap := True;
  FontSize := FFont.Size;
  GMemo.Font.PixelsPerInch := FPixelsPerInch;
  GMemo.Font.Size := FontSize;
  GMemo.Height := abs(FLineHeight * 20);

  FindCarriageReturns;

  FMemoStream.Position := 0;
  GMemo.Lines.LoadFromStream( FMemoStream );

  if FSuppressBlankLines then
  begin
    Spot := 0;
    while Spot < GMemo.Lines.Count do
    begin
      if GMemo.Lines[Spot] = '' then
      begin
        GMemo.Lines.Delete(Spot);
        DeleteCR(Spot);
      end else Inc(Spot);
    end;
  end;
  if FSuppressWhiteSpace then
  begin
    Spot := 0;
    { Suppress leading }
    while Spot = 0 do
    begin
      if GMemo.Lines.Count > 0 then
      begin
        if GMemo.Lines[0] = '' then
        begin
          GMemo.Lines.Delete(0);
          DeleteCR(0);
        end else Spot := 1;
      end else Spot := 1;
    end;
    { Suppress trailing }
    Spot := 0;
    while Spot = 0 do
    begin
      if GMemo.Lines.Count > 0 then
      begin
        if GMemo.Lines[GMemo.Lines.Count - 1] = '' then
        begin
          GMemo.Lines.Delete(GMemo.Lines.Count - 1);
          DeleteCR(GMemo.Lines.Count - 1);
        end else Spot := 1;
      end else Spot := 1;
    end;
  end;
  FMemoLines := GMemo.Lines.Count;
  if (FMemoLines > 0) and (not WrapText) then FMemoLines := 1;
  FMemoStrings.Assign( GMemo.Lines );


end;

function TAceMemo.GetPrintHeight: Integer;
var
  StartLine, EndLine: Integer;
begin
  StartLine := FRangeBegin;
  EndLine := FRangeEnd;
  if StartLine < 0 then StartLine := 0;
  if (EndLine < 0) or (EndLine >= FMemoLines) then EndLine := FMemoLines - 1;
  result := FLineHeight * (EndLine - StartLine + 1);
end;

{---------------------------------------------------}
{ Passing 0 as the StartLine and EndLine will cause }
{ the procedure to print all memo lines.            }
{---------------------------------------------------}
procedure TAceMemo.Print(AceCanvas:TAceCanvas; x,y:Integer);
var
  position: Integer;
  Str: String;
  Rect: TRect;
  StartLine, EndLine: Integer;
begin
  UpdateMemo;
  AceCanvas.Font := FFont;
  if FMemoLines > 0 Then
  begin
    StartLine := FRangeBegin;
    EndLine := FRangeEnd;
    if StartLine < 0 then StartLine := 0;
    if (EndLine < 0) or (EndLine >= FMemoLines) then EndLine := FMemoLines - 1;

    for position := StartLine to EndLine do
    begin
      Rect := Bounds( x, y+((position-StartLine)* FLineHeight),
                      Width, FLineHeight );

      Str := FMemoStrings[position];
      PrintLine(AceCanvas, Str, Rect, Position);
    end;
  end;
end;

procedure TAceMemo.PrintLine(AceCanvas: TAceCanvas; Text: String;
                               Rect: TRect; Spot: Integer);
var
  tsp: TAceTabStringPos;
  pos, count: Integer;
  JustifyText: Boolean;
  CRCount: Integer;
  Found: Boolean;
  Align: Integer;
  start: Integer;
  R: TRect;
begin
  JustifyText := False;

  if FMemoAlignment = maJustify then
  begin
    JustifyText := True;
    Count := 0;
    Found := False;
    CRCount := CarriageReturnList.Count;
    while (count < CRCount) and (not Found) do
    begin
      if Spot = (FMemoLines - 1) then
      begin
        Found := True;
        JustifyText := FJustifyLastLine;
      end else if (Integer(CarriageReturnList.Items[count]) = Spot ) then
      begin
        Found := True;
        JustifyText := False;
      end;
      Inc(count);
    end;
  end;

  AceCanvas.Font := FFont;
  start := 0;
  Align := 0;
  case FMemoAlignment of
    maLeft, maJustify: Align := TA_LEFT;
    maCenter: Align := TA_CENTER;
    maRight:  Align := TA_RIGHT;
  end;
  AceCanvas.SetTextAlign(Align + TA_TOP);

  ParseString(Text);
  for pos := 0 to FParts.Count - 1 do
  begin
    R := Rect;
    tsp := TAceTabStringPos(FParts.items[pos]);
    case FMemoAlignment of
      maLeft, maJustify:
      begin
        start := Rect.Left + tsp.Pos;
        R.Right := start + GForm.Canvas.TextWidth(tsp.text);
      end;
      maCenter:
      begin
        start := Rect.Left + tsp.Pos
            + (GForm.Canvas.TextWidth(tsp.text) div 2)
            + ((Width - FTextLen) div 2);
        R.Right := start + (GForm.Canvas.TextWidth(tsp.text) div 2);
      end;
      maRight:
      begin
        start := Rect.Left + tsp.Pos + GForm.Canvas.TextWidth(tsp.text)
            + (Width - FTextLen);
        R.Right := start;
      end;
    end;

    if ( pos = FParts.Count-1 ) and JustifyText then
    begin
      if FTextDriverCompatibility then AceCanvas.TextOut(start, Rect.Top, tsp.text)
      else AceCanvas.TextJustify(Rect, start, Rect.Top, tsp.text, False, Rect);
    end else
    begin
      if FTextDriverCompatibility then AceCanvas.TextOut(start, Rect.Top, tsp.text)
      else AceCanvas.TextJustify(R,start, Rect.Top, tsp.Text, True, Rect);
    end;
  end;
end;

procedure TAceMemo.FindCarriageReturns;
var
  TempStream: TMemoryStream;
  count, LastLineNum, start: Integer;
  Spot: ^Byte;
  MemoSize: Integer;
begin
  FCarriageReturnList.Clear;
  if FMemoAlignment = maJustify then
  begin
    TempStream := TMemoryStream.Create;
    try
      FMemoStream.Position := 0;
      spot := TMemoryStream(FMemoStream).memory;
      count := 0;
      LastLineNum := 0;
      start := count;
      MemoSize := FMemoStream.Size;
      while count < MemoSize do
      begin
        Inc(count);
        if (spot^ = 10) or (count = MemoSize) then
        begin
          TempStream.Clear;
          FMemoStream.Position := start;
          TempStream.CopyFrom(FMemoStream, count - start);
          TempStream.Position := 0;

          GMemo.Lines.LoadFromStream( TempStream );

          FCarriageReturnList.Add(Pointer(GMemo.Lines.Count + LastLineNum - 1));
          LastLineNum := LastLineNum + GMemo.Lines.Count;
          start := count;
        end;
        Inc(spot);
      end;
    finally
      TempStream.Free;
    end;
  end;
end;

procedure TAceMemo.ClearParts;
var
  pos: Integer;
begin
  if FParts <> nil then
  begin
    for pos := 0 to FParts.Count - 1 do
    begin
      TObject(FParts.items[pos]).free;
    end;
    FParts.Clear;
  end;
end;

procedure TAceMemo.ParseString(S: String);
var
  Spot: Integer;
  Send: String;
  Pos: Integer;
  half: Integer;
  Width: Integer;
  tsp: TAceTabStringPos;
begin
  tsp := nil;
  ClearParts;
  Send := '';
  Pos := 0;
  half := PixelsPerInch div 2;
  for Spot := 1 to Length(S) do
  begin
    if S[Spot] = Chr(9) then
    begin
      tsp := TAceTabStringPos.Create;
      FParts.Add(tsp);
      tsp.Text := Send;
      tsp.Pos := pos;

      Width := GForm.Canvas.TextWidth(Send);
      tsp.Width := Width;
      { add length of string to current pos }
      Pos := Pos + Width;
      { add in the tab }
      Pos := (pos div half) * half + half;
      Send := '';
    end else Send := Send + S[Spot];
  end;
  if Length(Send) > 0 then
  begin
    tsp := TAceTabStringPos.Create;
    FParts.Add(tsp);
    tsp.Text := Send;
    tsp.Pos := pos;
    tsp.Width := GForm.Canvas.TextWidth(Send);
  end;
  if tsp <> nil then FTextLen := tsp.Pos + GForm.Canvas.TextWidth(tsp.text)
  else FTextLen := 0;
end;

Initialization
 { in Delphi32 the memo always displays on the band
   even when visible = False so  I had to create it
   on an invisible form to do a work around        }
  GForm := nil;
  GMemo := nil;

  { This form and memo will get deleted when the application
    is closed }

  GForm := TForm.Create(Application);
  GForm.Visible := False;
  GForm.Height := 1000;
  GForm.Width := 1000;
  GMemo := TMemo.Create(GForm);
  GMemo.Parent := GForm;
  GMemo.Visible := False;

end.
{------------------------------------------------------------------------------}