updfwriter.pas

DelphiDoc is a program for automatic generation of documentation on a Delphi-Project. At the momen

~param DefaultWidth default width of characters
~param Ascent       maximum ascent of characters of the font from the base line
~param Descent      maximum descent of characters of the font from the base
                    line }
constructor TType1Font.Create(const Widths: TCharWidths; DefaultWidth: Integer;
                              Ascent, Descent: Integer);
begin
 inherited Create;              //create the object

 FWidths := Widths;             //save the data of the font
 FDefaultWidth := DefaultWidth;
 FAscent := Ascent;
 FDescent := Descent;
end;


{Returns the width of the text in this font.
~param Text the text to measure with this font
~result the width of the text with this font }
function TType1Font.TextWidth(const Text: String): TPDFValue;
begin
 if Text <> '' then                 //characters available?
  //calculate their width
  Result := TextWidthCharacters(Pointer(Text), Length(Text))
 else
  Result := 0;                        //no characters, no width required
end;

{Returns the total width of the characters in this font.
~param Characters pointer to the characters to be measured
~param Count      the number of characters to be measured
~result the total width of the characters in this font }
function TType1Font.TextWidthCharacters(Characters: PChar;
                                        Count: Integer): TPDFValue;
begin
 Result := 0;                       //no characters so far => no width required
 if Count <> 0 then                 //characters available?
  begin
   for Count := 1 to Count do         //for each character
    begin
     //the width of the character is defined?
     if Characters^ in [Low(FWidths)..High(FWidths)] then
      Result := Result + FWidths[Characters^]     //use defined width
     else
      Result := Result + FDefaultWidth;           //default width of characters
     Inc(Characters);
    end;
   Result := Result / 1000;           //use page metric, not glyph metric
  end;
end;


{Returns the number of fitting characters of the text in the given length in
 this font.
~param Text   the text to measure with this font
~param AWidth the (maximal) width of the text
~result the number of characters of the string fitting in the length with this
        font }
function TType1Font.FittingText(const Text: String;
                                AWidth: TPDFValue): Integer;
var      pc        :PChar;     //counter through the text
         CharWidth :Integer;   //width of each character
begin
 Result := 0;                  //no characters fit so far
 if Text <> '' then            //text not empty?
  begin
   pc := Pointer(Text);        //for each character while width not reached
   while (pc^ <> #0) and (AWidth >= 0) do
    begin
     if pc^ in [Low(FWidths)..High(FWidths)] then //width of character defined?
      CharWidth := FWidths[pc^]                     //use defined width
     else
      CharWidth := FDefaultWidth;             //use default width of characters
      //subtract width of the character from the width
     AWidth := AWidth - CharWidth / 1000;

     Inc(pc);                    //next character
    end;

    //calculate number of fitting character
   Result := Integer(pc) - Integer(Pointer(Text));
   if (pc^ <> #0) and (pc <> Pointer(Text)) then //not end of the text reached?
    Dec(Result);                 //last character doesn't fit
  end; //if Text <> ''
end;


{Gets the widths of the specified characters.
~param Text       the characters whose widths should be calculated
~param Widths     the array to add the widths to
~param StartIndex the index of the first entry to add the widths in the array }
procedure TType1Font.GetCharacterWidths(const Text: String;
                                        var Widths: array of TPDFValue;
                                        StartIndex: Integer);
var       PWidths   :^TPDFValue;            //runner through the widths
          PText     :PChar;                 //runner through the text
          i         :Integer;               //counter through all characters
          c         :Char;                  //each character
begin
 PWidths := @Widths[StartIndex];            //initialize runners
 PText := Pointer(Text);
 for i := 1 to Length(Text) do              //for each character
  begin
   c := PText^;                               //get it
   Inc(PText);
   if c in [Low(FWidths)..High(FWidths)] then //width of character defined?
    PWidths^ := FWidths[c]                      //use defined width
   else
    PWidths^ := FDefaultWidth;                  //default width of characters
   Inc(PWidths);                              //set for next width
  end;
end;














   { * * *  ***  * * *  ***   TPDFWriter   ***  * * *  ***  * * *  }



{Creates the object and starts the PDF file.
~param Stream the stream to write the PDF file to }
constructor TPDFWriter.Create(Stream: TStream);
begin
 inherited Create;                //create the object

 FStream := Stream;               //save the stream

 FCompression := True;            //use compression by default

 FPageWidth := 596;               //use DIN A4 pages
 FPageHeight := 842;

 //create list for images in the PDF file
 FImages := TStringList.Create;
 FImages.Sorted := True;
 FImages.Duplicates := dupError;
 //create list for sizes of the images
 FImageSizes := TList.Create;

 //create list for images in the current page of the PDF file
 FImageReferences := TStringList.Create;
 FImages.Sorted := True;
 FImages.Duplicates := dupIgnore;

 FPagesTreeNumberInNodes := 12;   //use 12 pages per array entry in page tree

 //create list for all destinations
 FDestNameTreeItems := TStringList.Create;
 FDestNameTreeNumberInNodes := 12;  //use 12 items per array entry in name tree


 FObjPositions := TList.Create;   //create list of positions of all PDF objects

 //create list of all destinations in the current page
 FDestinations := TStringList.Create;
 //create list of the names of all destinations in the current page
 FDestinationNames := TStringList.Create;
 //create list of aliases of destinations in the current page
 FDestinationAliases := TStringList.Create;
 //create list of all annotations in the current page
 FAnnotations := TStringList.Create;


 CreateFonts;                     //create all (default) fonts

 FPageStream := TMemoryStream.Create; //create stream for content of the pages

 FInsertionPoint := -1;           //no insertion point defined so far


 Write('%PDF-1.2');               //start the PDF file
 
 //create the first object for the references to the pages;
 //it is empty, it will be created as the last object in the PDF file after
 //all pages but before its "Catalog" (outline, destinations etc.);
 //the offset in FObjPositions[0] will be adjusted then
 GetAddObjPosNumber;
end;

{Frees the object and all fields. }
destructor TPDFWriter.Destroy;
var        fs        :TPDFFontType;  //each font
           i         :Integer;       //each font style combination
begin
 FPageStream.Free;                   //free stream for content of the pages


 for fs := low(fs) to high(fs) do    //for each font
  for i := low(FFonts[low(fs)]) to high(FFonts[low(fs)]) do
   FFonts[fs, i].Free;                 //free it


 FImageReferences.Free;   //free list of images in the current page
 FImageSizes.Free;        //free lists for images in the PDF file
 FImages.Free;
 FDestinations.Free;      //free list of all destinations in the current page
 //free list of the names of all destinations in the current page
 FDestinationNames.Free;
 //free list of aliases of destinations in the current page
 FDestinationAliases.Free;
 FAnnotations.Free;       //free list of all annotations in the current page


 FObjPositions.Free;      //list of all page objects

 FDestNameTreeItems.Free; //free list of all destinations


 inherited Destroy;       //free the object
end;













{Sets the group to add pages to.
~param Value the index to of the group of pages to add new pages to }
procedure TPDFWriter.SetPageGroupInsertPos(Value :Integer);
begin
 EndPageGroup;                                  //end the current group

 Assert(Value >= 0);
 Assert(Value <= Length(FPageGroups));

 FPageGroupInsertPos := Value;                  //set insert position
end;


{Creates all fonts into ~[link FFonts]. }
procedure TPDFWriter.CreateFonts;
          //widths of characters of font Courier (New) in all styles
          //(fixed width, all characters are 600 milli points)
const     CharWidths_Courier: TCharWidths = (
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,600,
              600,600);

          //widths of characters of Helvetica (Helv, Arial) in normal style and
          //italy
          CharWidths_Helvetica: TCharWidths = (
              278,278,355,556,556,889,667,191,333,333,389,584,278,333,
              278,278,556,556,556,556,556,556,556,556,556,556,278,278,584,584,
              584,556,1015,667,667,722,722,667,611,778,722,278,500,667,556,833,
              722,778,667,778,722,667,611,722,667,944,667,667,611,278,278,278,
              469,556,333,556,556,500,556,556,278,556,556,222,222,500,222,833,
              556,556,556,556,333,500,278,556,500,722,500,500,500,334,260,334,
              584,0,556,0,222,556,333,1000,556,556,333,1000,667,333,1000,0,
              611,0,0,222,222,333,333,350,556,1000,333,1000,500,333,944,0,
              500,667,0,333,556,556,556,556,260,556,333,737,370,556,584,0,
              737,333,400,584,333,333,333,556,537,278,333,333,365,556,834,834,
              834,611,667,667,667,667,667,667,1000,722,667,667,667,667,278,278,
              278,278,722,722,778,778,778,778,778,584,778,722,722,722,722,667,
              667,611,556,556,556,556,556,556,889,500,556,556,556,556,278,278,
              278,278,556,556,556,556,556,556,556,584,611,556,556,556,556,500,
              556,500);

          //widths of characters of Helvetica (Helv, Arial) in bold style and
          //bold and italy
          CharWidths_Helvetica_Bold: TCharWidths = (
              278,333,474,556,556,889,722,238,333,333,389,584,278,333,
              278,278,556,556,556,556,556,556,556,556,556,556,333,333,584,584,
              584,611,975,722,722,722,722,667,611,778,722,278,556,722,611,833,
              722,778,667,778,722,667,611,722,667,944,667,667,611,333,278,333,
              584,556,333,556,611,556,611,556,333,611,611,278,278,556,278,889,
              611,611,611,611,389,556,333,611,556,778,556,556,500,389,280,389,
              584,0,556,0,278,556,500,1000,556,556,333,1000,667,333,1000,0,
              611,0,0,278,278,500,500,350,556,1000,333,1000,556,333,944,0,
              500,667,0,333,556,556,556,556,280,556,333,737,370,556,584,0,
              737,333,400,584,333,333,333,611,556,278,333,333,365,556,834,834,
              834,611,722,722,722,722,722,722,1000,722,667,667,667,667,278,278,
              278,278,722,722,778,778,778,778,778,584,778,722,722,722,722,667,
              667,611,556,556,556,556,556,556,889,556,556,556,556,556,278,278,
              278,278,611,611,611,611,611,611,611,584,611,611,611,611,611,556,
              611,556);

          //widths of characters of Times (New Roman) in normal style
          CharWidths_TimesNewRoman: TCharWidths = (
              250,333,408,500,500,833,778,180,333,333,500,564,250,333,
              250,278,500,500,500,500,500,500,500,500,500,500,278,278,564,564,
              564,444,921,722,667,667,722,611,556,722,722,333,389,722,611,889,
              722,722,556,722,667,556,611,722,722,944,722,722,611,333,278,333,
              469,500,333,444,500,444,500,444,333,500,500,278,278,500,278,778,
              500,500,500,500,333,389,278,500,500,722,500,500,444,480,200,480,
              541,0,500,0,333,500,444,1000,500,500,333,1000,556,333,889,0,
              611,0,0,333,333,444,444,350,500,1000,333,980,389,333,722,0,
              444,722,0,333,500,500,500,500,200,500,333,760,276,500,564,0,
              760,333,400,564,300,300,333,500,453,250,333,300,310,500,750,750,
              750,444,722,722,722,722,722,722,889,667,611,611,611,611,333,333,
              333,333,722,722,722,722,722,722,722,564,722,722,722,722,722,722,