frxexporttxt.pas

报表源码 FastReport 3 is new generation of the report generators components. It consists of report engin

end;

function TfrxTXTExport.FindStyle(Style: PfrxTXTStyle): Integer;
var
  i: Integer;
begin
  Result := -1;
  for i := 0 to StyleList.Count - 1 do
    if CompareStyles(Style, PfrxTXTStyle(StyleList[i])) then
      Result := i;
end;

procedure TfrxTXTExport.MakeStyleList;
var
  i, j, k: Integer;
  obj: TfrxView;
  style: PfrxTXTStyle;
begin
  j := 0;
  for i := 0 to ObjectPos.Count - 1 do
  begin
    obj := PageObj[PObjPos(ObjectPos[i]).obj];
    style := AllocMem(SizeOf(TfrxTXTStyle));
    if obj is TfrxCustomMemoView then
    begin
      style.Font := TFont.Create;
      style.Font.Assign(TfrxMemoView(obj).Font);
      style.VAlignment := TfrxMemoView(obj).VAlign;
      style.HAlignment := TfrxMemoView(obj).HAlign;
      style.IsText := True;
    end
    else
    begin
      style.Font := nil;
      style.IsText := False;
    end;
    style.FrameTyp := obj.Frame.Typ;
    style.FrameWidth := obj.Frame.Width;
    style.FrameColor := obj.Frame.Color;
    style.FrameStyle := obj.Frame.Style;
    style.FillColor := obj.Color;
    k := FindStyle(Style);
    if k = -1 then
    begin
      StyleList.Add(style);
      PObjPos(ObjectPos[i]).style := j;
      j := j + 1;
    end
    else
    begin
      PObjPos(ObjectPos[i]).style := k;
      Style.Font.Free;
      FreeMemory(Style);
    end;
  end;
end;

function StrToOem(const AnsiStr: String): String;
begin
  SetLength(Result, Length(AnsiStr));
  if Length(Result) > 0 then
    CharToOemBuff(PChar(AnsiStr), PChar(Result), Length(Result));
end;

function MakeStr(C: Char; N: Integer): String;
begin
  if N < 1 then
    Result := ''
  else
  begin
    SetLength(Result, N);
    FillChar(Result[1], Length(Result), C);
  end;
end;

function AddChar(C: Char; const S: String; N: Integer): String;
begin
  if Length(S) < N then
    Result := MakeStr(C, N - Length(S)) + S else
    Result := S;
end;

function AddCharR(C: Char; const S: String; N: Integer): String;
begin
  if Length(S) < N then
    Result := S + MakeStr(C, N - Length(S)) else
    Result := S;
end;

function LeftStr(const S: String; N: Integer): String;
begin
  Result := AddCharR(' ', S, N);
end;

function RightStr(const S: String; N: Integer): String;
begin
  Result := AddChar(' ', S, N);
end;

function CenterStr(const S: String; Len: Integer): String;
begin
  if Length(S) < Len then
  begin
    Result := MakeStr(' ', (Len div 2) - (Length(S) div 2)) + S;
    Result := Result + MakeStr(' ', Len - Length(Result));
  end
  else
    Result := S;
end;

const
  Delims = [' ', #9, '-'];

function WrapTxt(s: String; dx, dy: Integer): String;
var
  i, j, k: Integer;
  buf1, buf2: String;
begin
  i := 0;
  buf2 := s;
  Result := '';
  while (i < dy) and (Length(Buf2) > 0) do
  begin
    if Length(buf2) > dx then
    begin
      if buf2[dx + 1] = #10 then
        buf1 := copy(buf2, 1, dx + 1)
      else if buf2[dx + 1] = #13 then
        buf1 := copy(buf2, 1, dx + 2)
      else
        buf1 := copy(buf2, 1, dx)
    end
    else
    begin
      Result := Result + buf2;
      break;
    end;
    k := Pos(#13#10, buf1);
    if k > 0 then
      j := k + 1
    else if Length(Buf1) < dx  then
    begin
      j := Length(Buf1);
      k := 1;
    end
    else
      j := dx;
    if (not (buf2[dx + 1] in Delims)) or (k > 0) then
    begin
      if k = 0 then
        while (j > 0) and (not (buf1[j] in Delims)) do
          Dec(j);
      if j > 0 then
      begin
        buf1 := copy(buf1, 1, j);
        buf2 := copy(buf2, j + 1, Length(buf2) - j)
      end
      else
        buf2 := copy(buf2, dx + 1, Length(buf2) - dx);
    end
    else
      buf2 := copy(buf2, dx + 2, Length(buf2) - dx - 1);
    i := i + 1;
    Result := Result + buf1;
    if k = 0 then
      Result := Result + #13#10;
  end;
end;

procedure TfrxTXTExport.WriteExpLn(const str: String);
var
  ln: String;
begin
  if Length(str) > 0 then
  begin
    if Length(str) > PageWidth then
      PageWidth := Length(str);
    Inc(PageHeight);
    Stream.Write(str[1], Length(str));
    ln := #13#10;
    Stream.Write(ln[1], Length(ln));
  end
  else if expEmptyLines then
  begin
    ln := #13#10;
    Inc(PageHeight);
    Stream.Write(ln[1], Length(ln));
  end;
end;

procedure TfrxTXTExport.WriteExp(const str: String);
begin
  if Length(str) > 0 then
    Stream.Write(str[1], Length(str))
end;

procedure TfrxTXTExport.CreateScr(dx, dy: Integer);
var
  i, j: Integer;
begin
  ScrWidth := dx;
  ScrHeight := dy;
  Initialize(Scr);
  SetLength(Scr, ScrWidth * ScrHeight);
  for i := 0 to ScrHeight - 1 do
    for j := 0 to ScrWidth - 1 do
      Scr[i * ScrWidth + j] := ' ';
end;

procedure TfrxTXTExport.ScrString(x, y: Integer; const s: String);
var
  i: Integer;
begin
  for i := 0 to Length(s) - 1 do
    ScrType(x + i, y, s[i + 1]);
end;

function TfrxTXTExport.ScrGet(x, y: Integer): Char;
begin
 if (x < ScrWidth) and (y < ScrHeight) and
   (x >= 0) and (y >= 0) then
   Result := Scr[ScrWidth * y + x] else
   Result := ' ';
end;

procedure TfrxTXTExport.DrawMemo(x, y, dx, dy: Integer; text: String;
  st: Integer);
var
  i, sx, sy, lines: Integer;
  buf: String;
  style: PfrxTXTStyle;
  f: String;

  function AlignBuf: String;
  begin
    if (style.HAlignment = haLeft) then
      buf := LeftStr(buf, dx - 1)
    else if (style.HAlignment = haRight) then
      buf := RightStr(buf, dx - 1)
    else if (style.HAlignment = haCenter) then
      buf := CenterStr(buf, dx - 1)
    else
      buf := LeftStr(buf, dx - 1);
    if expOEM then
      buf := StrToOem(buf);
    Result := buf;
  end;

begin
  style := PfrxTXTStyle(StyleList[st]);
  if (Style.FrameTyp <> []) and expBorders then
  begin
    if Length(expCustomFrameSet) > 0 then
      f := CustomFrameSet
    else if expBordersGraph then
      f := FrameSet[2]
    else
      f := FrameSet[1];
    if (ScrGet(x + 1, y) in [f[1], f[3], f[4]]) then
    begin
      Inc(x);
      Dec(dx);
    end
    else if (ScrGet(x - 1, y) in [f[1], f[3], f[4]]) then
    begin
      Dec(x);
      Inc(dx);
    end;
    if (ftLeft in Style.FrameTyp) then
      for i := 0 to dy do
        if i = 0 then
          ScrType(x, y + i, f[3])
        else if i = dy then
          ScrType(x, y + i, f[5])
        else
          ScrType(x, y + i, f[1]);
    if (ftRight in Style.FrameTyp) then
      for i := 0 to dy do
        if i = 0 then
          ScrType(x + dx, y + i, f[4])
        else if i = dy then
          ScrType(x + dx, y + i, f[6])
        else
          ScrType(x + dx, y + i, f[1]);
    if (ftTop in Style.FrameTyp) then
      for i := 0 to dx do
        if i = 0 then
          ScrType(x + i, y, f[3])
        else if i = dx then
          ScrType(x + i, y, f[4])
        else
          ScrType(x + i, y, f[2]);
    if (ftBottom in Style.FrameTyp) then
      for i := 0 to dx do
        if i = 0 then
          ScrType(x + i, y + dy, f[5])
        else if i = dx then
          ScrType(x + i, y + dy, f[6])
        else
          ScrType(x + i, y + dy, f[2]);
  end;
  text := WrapTxt(text, dx - 1, dy - 1);
  text := StringReplace(text, #13#10, #13, [rfReplaceAll]);
  lines := 1;
  for i := 0 to Length(text) - 1 do
    if text[i + 1] = #13 then
      Inc(lines);
  sx := x;
  if (style.VAlignment = vaBottom) then
    sy := y + dy - lines - 1
  else if (style.VAlignment = vaCenter) then
    sy := y + (dy - lines - 1) div 2
  else
    sy := y;
  buf := '';
  for i := 0 to Length(text) - 1 do
    if text[i + 1] = #13 then
    begin
      Inc(sy);
      if sy > (y + dy) then
        break;
      ScrString(sx + 1, sy, AlignBuf);
      buf := '';
    end
    else
    begin
      buf := buf + text[i + 1];
    end;
  if buf <> '' then
    ScrString(sx + 1, sy + 1, AlignBuf);
end;

procedure TfrxTXTExport.FlushScr;
var
  i, j, cnt, maxcnt: Integer;
  buf: String;
  f: String;
  c: Char;

  function IsLine(c: Char): Boolean;
  begin
    Result := (c in [f[1], f[2]]);
  end;

  function IsConner(c: Char): Boolean;
  begin
    Result := (c in [f[3], f[4], f[5], f[6], f[7], f[8], f[9], f[10], f[11]]);
  end;

  function IsFrame(c: Char): Boolean;
  begin
    Result := IsLine(c) or IsConner(c);
  end;

  function FrameOpt(c: Char; x, y: Integer; f: String): Char;
  begin
    if (not IsLine(ScrGet(x - 1, y))) and
      (not IsLine(ScrGet(x + 1, y))) and
      (not IsLine(ScrGet(x, y - 1))) and
      (IsLine(ScrGet(x, y + 1))) then
      Result := f[1]
    else if (not IsLine(ScrGet(x - 1, y))) and
      (not IsLine(ScrGet(x + 1, y))) and
      (IsLine(ScrGet(x, y - 1))) and
      (not IsLine(ScrGet(x, y + 1))) then
      Result := f[1]
    else if (not IsLine(ScrGet(x - 1, y))) and
      (IsLine(ScrGet(x + 1, y))) and
      (not IsLine(ScrGet(x, y - 1))) and
      (not IsLine(ScrGet(x, y + 1))) then
      Result := f[2]
    else if (not IsLine(ScrGet(x + 1, y))) and
      (IsLine(ScrGet(x - 1, y))) and
      (not IsLine(ScrGet(x, y - 1))) and
      (not IsLine(ScrGet(x, y + 1))) then
      Result := f[2]
    else if (not IsFrame(ScrGet(x + 1, y))) and
      (not IsFrame(ScrGet(x - 1, y))) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x, y - 1) = f[1]) then
      Result := f[1]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (not IsFrame(ScrGet(x, y + 1))) and
      (not IsFrame(ScrGet(x, y - 1))) then
      Result := f[2]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x, y - 1) = f[1]) then
      Result := f[11]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x, y - 1) <> f[1]) then
      Result := f[9]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x, y - 1) = f[1]) and
      (ScrGet(x, y + 1) <> f[1]) then
      Result := f[7]
    else if (ScrGet(x, y - 1) = f[1]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) <> f[2])then
      Result := f[8]
    else if (ScrGet(x, y - 1) = f[1]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x + 1, y) <> f[2])then
      Result := f[10]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) <> f[2]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x, y - 1) <> f[1]) then
      Result := f[3]
    else if (ScrGet(x + 1, y) = f[2]) and
      (ScrGet(x - 1, y) <> f[2]) and
      (ScrGet(x, y + 1) <> f[1]) and
      (ScrGet(x, y - 1) = f[1]) then
      Result := f[5]
    else if (ScrGet(x + 1, y) <> f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x, y + 1) <> f[1]) and
      (ScrGet(x, y - 1) = f[1]) then
      Result := f[6]
    else if (ScrGet(x + 1, y) <> f[2]) and
      (ScrGet(x - 1, y) = f[2]) and
      (ScrGet(x, y + 1) = f[1]) and
      (ScrGet(x, y - 1) <> f[1]) then
      Result := f[4]
    else
      Result := c;
  end;

begin
  if expBorders then
  begin
    if Length(expCustomFrameSet) > 0 then
      f := CustomFrameSet
    else if expBordersGraph then
      f := FrameSet[2]
    else
      f := FrameSet[1];
    for i := 0 to ScrHeight - 1 do
      for j := 0 to ScrWidth - 1 do
      begin
        c := Scr[i * ScrWidth + j];
        if IsConner(c) then
          Scr[i * ScrWidth + j] := FrameOpt(c, j, i, f);
      end;
  end;
  if not expLeadSpaces then
  begin
    maxcnt := 99999;
    for i := 0 to ScrHeight - 1 do
    begin
      cnt := 0;
      for j := 0 to ScrWidth - 1 do
        if (Scr[i * ScrWidth + j] = ' ') then
          Inc(cnt) else
          break;
      if cnt < maxcnt then
        maxcnt := cnt;
    end;
  end
  else
    maxcnt := 0;
  for i := 0 to ScrHeight - 1 do
  begin
    buf := '';
    for j := 0 to ScrWidth - 1 do
      buf := buf + Scr[i * ScrWidth + j];
    buf := TrimRight(buf);
    if (maxcnt > 0) then
      buf := Copy(buf, maxcnt + 1, Length(buf) - maxcnt);
    WriteExpLn(buf);
  end;
end;

procedure TfrxTXTExport.FreeScr;
begin
  Finalize(Scr);
  ScrHeight := 0;
  ScrWidth := 0;
end;

procedure TfrxTXTExport.ScrType(x,y: Integer; c: Char);
var
  i: Integer;
begin
  i := ScrWidth * y + x;
  if (not expOEM) and (c = #160) then
    c := ' ';
  Scr[i] := c;
end;

procedure TfrxTXTExport.ExportPage;
var
  i, x, y: Integer;
  s: String;
  obj: TfrxMemoView;