TEXT2PDF,TEXToPDF,TXT2PDF,TXTToPDF(Delphi SourceCode)

// -----------------------------------------------------------------------------
// TEXT2PDF,TEXToPDF,TXT2PDF,TXTToPDF
//
//                                                                (C) 2003 PAPY
//                                             http://homepage1.nifty.com/MADIA/
// -----------------------------------------------------------------------------

(* -------------- Support Japanese charcode "ShiftJIS" Only! -----------------*)

unit txt2pdf;

interface
uses
    Windows,Classes, Graphics, SysUtils;

    procedure TXTtoPDF(OpenName,SaveName:String);

implementation

 // ---------------------------
 //  A3 842x1191  297x420mm
 //  A4 595x842   210x297mm
 //  A5 420x595   148x210mm
 //  B4 729x1032  257x364mm
 //  B5 516x729   182x257mm
 // ---------------------------

 const
  m_PageWidth      = 595;           // 用紙の横サイズ
  m_PageHeight     = 842;           // 用紙の縦サイズ
  m_MarginX        = 30;            // 余白 (← →)
  m_MarginY        = 30;            // 余白 (↑ ↓)
  m_FontSize       = 12;            // フォントのサイズ (1-100ぐらいまで)
  m_FontName       = 'F0';          // フォントの変数名

  m_FontEncoding   = '90ms-RKSJ-H';             // フォントのエンコーディング
  m_FontWidth      = '231 389 500 631 631 500'; // 1byteフォントの幅

  type
    pDword =^Dword;
  type
    pDwordArray = ^TDwordArray ;
    TDwordArray  = array[0..1234] of Dword;

  { TPDFObjMemManager }
  type
   TPDFObjMemManager = class(TPersistent)
   private
     Buffer : Pointer;
     FObjectCount : Dword;
     FReallocCount: Dword;
     function GetSize():Dword;
   public
     ObjectIndex    : Dword;
     ObjectPosArray : pDwordArray;
     constructor Create(ObjectCount,ReallocCount :Dword);
     destructor Destroy;override;
     procedure MemoryCheck();
     property  MemorySize :Dword read GetSize;
  end;

////////////////////////////////////////////////////////////////////////////////

{ TPDFObjMemManager  }
constructor TPDFObjMemManager.Create(ObjectCount,ReallocCount :Dword);
begin
  inherited Create;

  if (ObjectCount=0) or (ReallocCount= 0) then
   raise  EInvalidOperation.Create('初期サイズは0にはできません。');

  FObjectCount   :=ObjectCount;
  FReallocCount  :=ReallocCount;
  GetMem(buffer,FObjectCount*SizeOf(TDwordArray));

  ObjectPosArray :=buffer;
  if Buffer=nil then
     raise EOutOfMemory.Create('メモリが不足しています。');
end;

destructor TPDFObjMemManager.Destroy;
begin
   FreeMem(Buffer,FObjectCount*SizeOf(SizeOf(TDwordArray)));
   inherited Destroy;
end;

function TPDFObjMemManager.GetSize():Dword;
begin
  Result:=FObjectCount* SizeOf(TDwordArray);
end;

procedure TPDFObjMemManager.MemoryCheck();
begin
  //  メモリの再編成
  if ObjectIndex >= FObjectCount then
  begin
     FObjectCount:=FObjectCount+FReallocCount;
     ReallocMem(Buffer,FObjectCount*SizeOf(TDwordArray));

     if Buffer=nil then
      raise EOutOfMemory.Create('メモリが不足しています。');

     // ポインタのアドレスが変更される場合があるので再割り当て
     ObjectPosArray := buffer;
  end;
end;

////////////////////////////////////////////////////////////////////////////////

procedure Write_CrossReferenceTable(AStream: TStream;ObjectPosArray : pDwordArray;Count:Integer);
Var
   i :Integer;
begin
  With TStringStream(AStream) do
  begin
    WriteString('xref'#10);
    WriteString(Format('0 %d'#10,[Count+1]));
    WriteString('0000000000 65535 f '#10);
    for i:= 0 to Count-1 do
    begin
     WriteString(Format('%0.10d',[ObjectPosArray[i]])+' 00000 n '#10);
    end;
  end;
end;

procedure DrawText(AStream: TStream;x,y:Integer;Lines :TStringList);

    function AsciiHexEncoding(Buffer :PByteArray;Size: Dword):String;
    Var
     i   : integer;
    begin
       TStringStream(AStream).WriteString('<');
       for i:= 0 to size-1 do
          TStringStream(AStream).WriteString(IntToHex(Buffer[i],2));
       TStringStream(AStream).WriteString('>');
    end;
    
Var
  i : Dword;
  Matrix   : Single;
begin
     if Lines.Text='' then Exit;

     y  := m_PageHeight - y;
     Matrix :=y - m_FontSize*0.87;
     With TStringStream(AStream) do
     begin
       WriteString('BT'#10);
       WriteString(Format('/%s %d Tf'#10,[m_FontName,m_FontSize]));
       WriteString(Format('0 0 0 rg %d TL %d %f Td ',[m_FontSize,x,Matrix]));

       AsciiHexEncoding(PByteArray(Lines[0]),Length(Lines[0]));
       WriteString(' Tj'#10);

       if Lines.Count<> 1 then
       begin
          for i:= 1 to Lines.Count -1 do
          begin
              WriteString('T* ');
              AsciiHexEncoding(PByteArray(Lines[i]),Length(Lines[i]));
              WriteString(' Tj'#10);
          end;
       end;
       WriteString('ET'#10);
     end;
end;

procedure AutoLineFeed(var Lines : TStringList);

   function GetTextWidth(S:String):Integer;
   begin
      Result:=(Length(S)* (m_FontSize div 2));
   end;
   
var
 P : Pchar;
 S : String;
 i,MaxWidth : integer;
 StringList   : TStringList;
begin   
    MaxWidth:=m_PageWidth-m_MarginX*2;

    StringList :=TStringList.Create;
    try
        for i:= 0 to Lines.Count-1 do
        begin
             // テキストがページの描画範囲を越える場合は改行する
             if GetTextWidth(Lines[i]) > MaxWidth then
             begin
                S :='';
                P :=Pchar(Lines[i]);
                While not (P^=#0) do
                begin
                   // Sjis漢字コード
                   if Byte(P^) in [$81..$9F,$E0..$FC] then
                   begin
                      S :=S+P^; inc(P);
                      S :=S+P^;
                      if GetTextWidth(S) > MaxWidth-(m_FontSize) then
                      begin
                         StringList.Add(S);
                         S :='';
                      end;
                      if P^=#0 then break;
                   end
                   // Ascii + 半角カタカナなど
                   else
                   begin
                      S :=S+P^;
                      if GetTextWidth(S) > MaxWidth-(m_FontSize div 2) then
                      begin
                         StringList.Add(S);
                         S :='';
                      end;
                   end; 
                   Inc(P);
                end;
                if S<>'' then
                  StringList.Add(S);
             end
             else
               StringList.Add(Lines[i]);

        end;
        Lines.Text:= StringList.Text;
    finally
      StringList.free;
    end;  
end;                    

procedure Write_PageObject(AStream: TStream;ObjectMem :TPDFObjMemManager; Lines,PageList : TStringList);
Var
   PageText :TStringList;
   i,j,k,Pages,Streamsize,MaxHeight,PageRows : integer;
begin

  PageText := TStringList.Create;
  try
      // テキストの自動整形
      AutoLineFeed(Lines);

      // 1ページで描画可能なサイズ
      MaxHeight:=m_PageHeight-m_MarginY*2;

      // 1ページに入る配列数
      PageRows:=Lines.count;
      for i:= 1 to Lines.count do
      begin
          if MaxHeight <= i * m_FontSize then
          begin
            PageRows:=i-1;
            break;
          end
      end;

      // ページ数の計算
      if Lines.Count<>0 then
      begin
        Pages := (Lines.Count div PageRows);
        if (Lines.Count-PageRows)<>0 then
         Inc(Pages);
      end
      else
        Pages:=1;
      
      k:=0;
      for i :=0 to Pages-1 do
      begin
          // 1ページ分の配列を受け取る 
          PageText.Text:='';
          for j:= 0 to PageRows-1 do
          begin
             if k >=Lines.Count then break;
             PageText.Add(Lines[k]);
             Inc(k);
          end;

          // Kids Page
          PageList.Add(Inttostr(ObjectMem.ObjectIndex+1));
          ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex] :=AStream.Position;
          With TStringStream(AStream) do
          begin
               WriteString(Format('%d 0 obj'#10,[ObjectMem.ObjectIndex+1]));
               WriteString('<<'#10);
               WriteString('/Type /Page'#10);
               WriteString('/Parent 2 0 R'#10);
               WriteString('/Resources'#10);
               WriteString('<<'#10);
               WriteString(Format('/Font << /%s 3 0 R >>'#10,[m_FontName]));
               WriteString('/ProcSet [ /PDF /Text ]'#10);
               WriteString('>>'#10);
               WriteString(Format('/MediaBox [ 0 0 %d %d ]'#10, [m_PageWidth,m_PageHeight]));
               WriteString(Format('/Contents %d 0 R'#10,[ObjectMem.ObjectIndex+2]));
               WriteString('>>'#10);
               WriteString('endobj'#10);
          end;
          Inc(ObjectMem.ObjectIndex);
          ObjectMem.MemoryCheck;

          // Contents Object
          ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex] :=AStream.Position;
          With TStringStream(AStream) do
          begin
               WriteString(Format('%d 0 obj'#10,[ObjectMem.ObjectIndex+1]));
               WriteString(Format('<< /Length %d 0 R >>'#10,[ObjectMem.ObjectIndex+2]));
               WriteString('stream'#10);

                 // stream
                 Streamsize := AStream.Position;
                 DrawText(AStream,m_MarginX,m_MarginY,PageText);
                 Streamsize := ASTream.Position-Streamsize;

               WriteString('endstream'#10);
               WriteString('endobj'#10);
          end;
          Inc(ObjectMem.ObjectIndex);
          ObjectMem.MemoryCheck;

          // Length Object
          ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex] :=AStream.Position;
          With TStringStream(AStream) do
          begin
               WriteString(Format('%d 0 obj'#10,[ObjectMem.ObjectIndex+1]));
               WriteString(Format('%d'#10,[Streamsize]));
               WriteString('endobj'#10);
          end;
          Inc(ObjectMem.ObjectIndex);
          ObjectMem.MemoryCheck;
       end;
       
   finally
     PageText.Free;
   end;
end;

procedure TXTtoPDF(OpenName,SaveName:String);
Var
  i :integer;
  AStream   : TStream;
  ObjectMem : TPDFObjMemManager;
  PageList,StringList  : TStringList;
begin

  if OpenName='' then
   raise  Exception.Create('OpenName is Empty');

  if SaveName='' then
   raise  Exception.Create('SaveName is Empty');

  AStream    :=TFileStream.Create(SaveName,fmCreate)  ;
  PageList   :=TStringList.Create;
  StringList :=TStringList.Create;
  ObjectMem  :=TPDFObjMemManager.Create(1000,1000);

  Try
     // ファイルの読み込み
     StringList.LoadFromFile(OpenName);

     // 最初のヘッダ部分は後で書き込む
     ObjectMem.ObjectIndex:=ObjectMem.ObjectIndex+2;       

     // PDF version
     TStringStream(AStream).WriteString('%PDF-1.2'#10);

     // Font Resource
     ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex] :=AStream.Position;
     With TStringStream(AStream) do
     begin
          WriteString(Format('%d 0 obj'#10,[ObjectMem.ObjectIndex+1]));
          WriteString('<<'#10);
          WriteString('/Type /Font'#10);
          WriteString(Format('/Name /%s'#10,[m_FontName]));
          WriteString(Format('/BaseFont /HeiseiKakuGo-W5-%s'#10,[m_FontEncoding]));
          WriteString('/Subtype /Type0'#10);
          WriteString(Format('/Encoding /%s'#10,[m_FontEncoding]));
          WriteString('/DescendantFonts [ << /Type /Font /Subtype /CIDFontType0 /BaseFont /HeiseiKakuGo-W5'#10);
          WriteString('/FontDescriptor << /Type /FontDescriptor /FontName /HeiseiKakuGo-W5 /ItalicAngle 0');
          WriteString('/FontBBox [ -92 -250 1010 922 ]'#10);
          WriteString('/Style << /Panose <');
          WriteString('0801020B0600000000000000');
          WriteString('>>> /Ascent 752 /CapHeight 737 /Descent -221'#10);
          WriteString('/Flags 4 /StemV 114 /XHeight 553 >>'#10);
          WriteString('/CIDSystemInfo << /Registry (Adobe)/Ordering (Japan1)/Supplement 2 >>'#10);
          WriteString(Format('/DW 1000 /W [ %s ] >>'#10,[m_FontWidth]));
          WriteString(']'#10);
          WriteString('>>'#10);
          WriteString('endobj'#10);
     end;
     Inc(ObjectMem.ObjectIndex);
     ObjectMem.MemoryCheck;

     // Write Page
     Write_PageObject(AStream,ObjectMem,StringList,PageList);

     // Catalog
     ObjectMem.ObjectPosArray[0] :=AStream.Position;
     With TStringStream(AStream) do
     begin
          WriteString('1 0 obj'#10);
          WriteString('<<'#10);
          WriteString('/Type /Catalog'#10);
          WriteString('/Pages 2 0 R'#10);
          WriteString('>>'#10);
          WriteString('endobj'#10);
     end;

     // Parent Pages
     ObjectMem.ObjectPosArray[1] :=AStream.Position;
     With TStringStream(AStream) do
     begin
          WriteString('2 0 obj'#10);
          WriteString('<<'#10);
          WriteString('/Type /Pages'#10);
          // Kids Pages
          WriteString('/Kids [');
          for i:= 0 to PageList.Count-1 do
          begin
            WriteString(Format(' %s 0 R',[PageList[i]]));
          end;
          WriteString(' ]'#10);
          WriteString(Format('/Count %d'#10,[PageList.Count]));
          WriteString('>>'#10);
          WriteString('endobj'#10);
     end;         

     // CrossReferenceTable
     ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex] :=AStream.Position;
     Write_CrossReferenceTable(AStream,ObjectMem.ObjectPosArray,ObjectMem.ObjectIndex);

     // trailer
     With TStringStream(AStream) do
     begin
         WriteString('trailer'#10);
         WriteString('<<'#10);
         WriteString(Format('/Size %d'#10,[ObjectMem.ObjectIndex+1]));
         WriteString('/Root 1 0 R'#10);
         WriteString('>>'#10);
         WriteString('startxref'#10);
         WriteString(Format('%d'#10,[ObjectMem.ObjectPosArray[ObjectMem.ObjectIndex]]));
         WriteString('%%EOF');
     end;

  finally
    AStream.Free;
    PageList.free;
    StringList.free;
    ObjectMem.free;
  end;
end;

end.