frxpdffile.pas

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

          WriteLn(Stream, '/Registry(Adobe)');
          WriteLn(Stream, '/Ordering(CNS1)');
          WriteLn(Stream, '/Supplement 0');
          WriteLn(Stream, '>>');
          WriteLn(Stream, '/DW 1000');
          WriteLn(Stream, '/W [1 95 500]');
          WriteLn(Stream, '>>');
          WriteLn(Stream, 'endobj');
        end;
      end;

      if Charset <> CHINESEBIG5_CHARSET then
      begin
        WriteLn(Stream, '/FontDescriptor ' + IntToStr(Index + 1 + Parent.FStartFonts) + ' 0 R');
        WriteLn(Stream, '/FirstChar ' + IntToStr(FirstChar));
        WriteLn(Stream, '/LastChar ' + IntToStr(LastChar));
        GetMem(pwidths, SizeOf(ABCArray));
        Write(Stream, '/Widths [');
        GetCharABCWidths(b.Canvas.Handle, FirstChar, LastChar, pwidths^);
        for i := 0 to (LastChar - FirstChar) do
          Write(Stream, IntToStr(pwidths^[i].abcA + Integer(pwidths^[i].abcB) + pwidths^[i].abcC) + ' ');
        WriteLn(Stream, ']');
        FreeMem(pwidths);
        WriteLn(Stream, '>>');
        WriteLn(Stream, 'endobj');
        Parent.XRefAdd(Stream);
        WriteLn(Stream, IntToStr(Index + 1 + Parent.FStartFonts) + ' 0 obj');
        WriteLn(Stream, '<<');
        WriteLn(Stream, '/Type /FontDescriptor');
        WriteLn(Stream, '/FontName /' + FontName);
        WriteLn(Stream, '/Flags 32');
        WriteLn(Stream, '/FontBBox [' + IntToStr(pm^.otmrcFontBox.Left) + ' '+ IntToStr(pm^.otmrcFontBox.Bottom) + ' '+ IntToStr(pm^.otmrcFontBox.Right) + ' '+ IntToStr(pm^.otmrcFontBox.Top) + ' ]');
        WriteLn(Stream, '/ItalicAngle ' + IntToStr(pm^.otmItalicAngle));
        WriteLn(Stream, '/Ascent ' + IntToStr(pm^.otmAscent));
        WriteLn(Stream, '/Descent ' + IntToStr(pm^.otmDescent));
        WriteLn(Stream, '/Leading ' + IntToStr(pm^.otmTextMetrics.tmInternalLeading)); //NEW
        WriteLn(Stream, '/CapHeight ' + IntToStr(pm^.otmTextMetrics.tmHeight));
        WriteLn(Stream, '/XHeight ' + IntToStr(pm^.otmsXHeight)); //NEW
        WriteLn(Stream, '/StemV ' + IntToStr(50 + Round(sqr(pm^.otmTextMetrics.tmWeight / 65))));
        WriteLn(Stream, '/AvgWidth ' + IntToStr(pm^.otmTextMetrics.tmAveCharWidth)); //NEW
        WriteLn(Stream, '/MaxWidth ' + IntToStr(pm^.otmTextMetrics.tmMaxCharWidth)); //NEW
        WriteLn(Stream, '/MissingWidth ' + IntToStr(pm^.otmTextMetrics.tmAveCharWidth)); //NEW
        if Parent.FEmbedded then
          WriteLn(Stream, '/FontFile2 ' + IntToStr(Index + 2 + Parent.FStartFonts) + ' 0 R');

        WriteLn(Stream, '>>');
        WriteLn(Stream, 'endobj');
      end;

      if Parent.FEmbedded then
      begin
        Parent.XRefAdd(Stream);
        WriteLn(Stream, IntToStr(Index + 2 + Parent.FStartFonts) + ' 0 obj');
        i := GetFontData(b.Canvas.Handle, 0, 0, nil, 1);
        GetMem(pfont, i);
        i := GetFontData(b.Canvas.Handle, 0, 0, pfont, i);
        MemStream := TMemoryStream.Create;
        MemStream.Write(pfont^, i);
        MemStream1 := TMemoryStream.Create;
        frxDeflateStream(MemStream, MemStream1, gzMax);
        WriteLn(Stream, '<< /Length ' + IntToStr(MemStream1.Size) + ' /Filter /FlateDecode /Length1 ' + IntToStr(MemStream.Size) + ' >>');
        WriteLn(Stream, 'stream');
        Stream.CopyFrom(MemStream1, 0);
        MemStream1.Free;
        MemStream.Free;
        FreeMem(pfont);
        WriteLn(Stream, '');
        WriteLn(Stream, 'endstream');
        WriteLn(Stream, 'endobj');
      end;
    except
    end;
  finally
    FreeMem(pm);
    b.Free;
  end;
end;

{ TfrxPDFElement }

constructor TfrxPDFElement.Create;
begin
  FIndex := 0;
  FXrefPosition := 0;
end;

procedure TfrxPDFElement.SaveToStream(Stream: TStream);
begin
  FXrefPosition := Stream.Position;
end;

procedure TfrxPDFElement.Write(Stream: TStream; S: String);
begin
  Stream.Write(S[1], Length(S));
end;

procedure TfrxPDFElement.WriteLn(Stream: TStream; S: String);
begin
  Stream.Write(S[1], Length(S));
  Stream.Write(#13#10, 2);
end;


{ TfrxPDFToolkit }

constructor TfrxPDFToolkit.Create;
begin
  Locale := GetLocaleInformation(LOCALE_SISO639LANGNAME);
  Prefix := UnicodePrefix;
end;

function TfrxPDFToolkit.GetLocaleInformation(Flag: Integer): String;
var
  pcLCA: array[0..20] of Char;
begin
  if (GetLocaleInfo(LOCALE_SYSTEM_DEFAULT, Flag, pcLCA,19) <= 0 ) then
    pcLCA[0] := #0;
  Result := pcLCA;
end;

function TfrxPDFToolkit.PrepareString(const Text: String): String;
begin
  if CheckOEM(Text) then
    Result := StrToOct(Prefix) + StrToOctUTF16(Text)
  else
    Result := Text;
end;

function TfrxPDFToolkit.GetHTextPos(Left: Extended; Width: Extended; const Text: String;
  Align: TfrxHAlign): Extended;
var
  FWidth: Extended;
begin
  if (Align = haLeft) or (Align = haBlock) then
    Result := Left
  else begin
    FWidth := GetLineWidth(Text);
    if Align = haCenter then
      Result := Left + Width / 2 - FWidth / 2
    else
      Result := Left + Width - FWidth;
  end;
end;

function TfrxPDFToolkit.GetLineWidth(const Text: String): Extended;
var
  FWidth: Extended;
begin
  frxDrawText.Lock;
  try
    FWidth := frxDrawText.Canvas.TextWidth(Text) / (frxDrawText.DefPPI / frxDrawText.ScrPPI);
  finally
    frxDrawText.UnLock;
  end;
  Result := FWidth;
end;

function TfrxPDFToolkit.GetVTextPos(Top: Extended; Height: Extended; const Text: String;
  Align: TfrxVAlign; Line: Integer = 0; Count: Integer = 1): Extended;
var
  i: Integer;
begin
  if Line <= Count then
    i := Line
  else
    i := 0;
  if Align = vaBottom then
    Result := Top + Height - LineHeight * (Count - i - 1)
  else if Align = vaCenter then
    Result := Top + Height / 2 - (LineHeight * Count) / 2 + LineHeight * (i + 1)
  else
    Result := Top + LineHeight * (i + 1);
end;

function TfrxPDFToolkit.TruncReturns(Str: string): string;
begin
  Str := StringReplace(Str, '\', '\\', [rfReplaceAll]);
  Str := StringReplace(Str, '(', '\(', [rfReplaceAll]);
  Str := StringReplace(Str, ')', '\)', [rfReplaceAll]);
  Str := StringReplace(Str, #1, '', [rfReplaceAll]);
  if Copy(Str, Length(Str) - 1, 2) = #13#10 then
    Delete(Str, Length(Str) - 1, 2);
  Result := Str;
end;

function TfrxPDFToolkit.UnicodePrefix: String;
begin
  Result := #254#255#0#27 + Locale + #0#27;
end;

function TfrxPDFToolkit.GetPDFColor(Color: TColor): String;
var
  TheRgbValue : TColorRef;
  OldSep: Char;
begin
  TheRgbValue := ColorToRGB(Color);
  OldSep := DecimalSeparator;
  DecimalSeparator := '.';
  Result := Format('%.2g %.2g %.2g', [GetRValue(TheRGBValue) / 255, GetGValue(TheRGBValue) / 255, GetBValue(TheRGBValue) / 255]);
  DecimalSeparator := OldSep;
end;

function TfrxPDFToolkit.CheckOEM(const Value: String): boolean;
var
  i: integer;
begin
  result := false;
  for i := 1 to Length(Value) do
    if (ByteType(Value, i) <> mbSingleByte) or
       (Ord(Value[i]) > 122) or
       (Ord(Value[i]) < 32) then
    begin
      result := true;
      Break;
    end;
end;

function TfrxPDFToolkit.StrToOctUTF16(const Value: String): String;
var
  PW: Pointer;
  PByte: ^Byte;
  HiByte, LoByte: Byte;
  Len: integer;
  i: integer;
begin
  result := '';
  Len := MultiByteToWideChar(0, CP_ACP, PChar(Value), Length(Value), nil, 0);
  GetMem(PW, Len * 2);
  Len := MultiByteToWideChar(0, CP_ACP, PChar(Value), Length(Value), PW, Len * 2);
  PByte := Pw;
  i := 0;
  while i < Len do
  begin
    LoByte := PByte^;
    inc(PByte);
    HiByte := PByte^;
    inc(PByte);
    result := result + '\' + Dec2Oct(HiByte) + '\' + Dec2Oct(LoByte);
    inc(i);
  end;
  FreeMem(PW);
end;

function TfrxPDFToolkit.Dec2Oct(i: Longint): string;
var
  m: Longint;
Begin
  Result := '';
  while i > 0 Do
  begin
    m := i mod 8;
    Result := Char(m + Ord('0')) + Result;
    i := i div 8;
  end;
  Result := StringOfChar('0',  3 - Length(Result)) + Result;
end;

function TfrxPDFToolkit.StrToOct(const Value: String): String;
var
  i: Integer;
begin
  for i := 1 to Length(Value) do
    Result := Result + '\' + Dec2Oct(Ord(Value[i]));
end;

procedure TfrxPDFToolkit.SetMemo(Memo: TfrxCustomMemoView);
begin
  frxDrawText.Lock;
  try
    frxDrawText.SetFont(Memo.Font);
    frxDrawText.SetGaps(0, 0, Memo.LineSpacing);
    LineHeight := frxDrawText.LineHeight;
  finally
    frxDrawText.UnLock;
  end;
end;

function TfrxPDFToolkit.Str2RTL(const Str: String): String;
var
  b, i, l: Integer;
  s: String;
  t, f: Boolean;
begin
  Result := ReverseString(Str);
  l := Length(Result);
  i := 1;
  b := 1;
  f := False;
  while i <= l do
  begin
    t := not ((Ord(Result[i]) > 32) and (Ord(Result[i]) < 122));
    if (t and f) then
    begin
      s := Copy(Result, b, i - b);
      Delete(Result, b, i - b);
      s := ReverseString(s);
      Insert(s, Result, b);
      f := False;
    end;
    if not (t or f) then
    begin
      b := i;
      f := True;
    end;
    i := i + 1;
  end;
end;

{ TfrxPDFOutlineNode }

constructor TfrxPDFOutlineNode.Create;
begin
  Title := '';
  Dest := -1;
  Number := 0;
  Count := 0;
  CountTree :=0;
  Parent := nil;
  First := nil;
  Prev := nil;
  Next := nil;
  Last := nil;
end;

destructor TfrxPDFOutlineNode.Destroy;
begin
  if Next <> nil then
    Next.Free;
  if First <> nil then
    First.Free;
  inherited;
end;

end.