unit txt2pdf;

interface
uses
    Windows,Classes, Graphics, SysUtils;

    procedure TXTtoPDF(OpenName,SaveName:String);

implementation

 const
  m_PageWidth      = 595; 
  m_PageHeight     = 842;

m_MarginX        = 30; 

  m_MarginY        = 30;

m_FontSize       = 12;

  m_FontName       = 'F0';

 m_FontEncoding   = '90ms-RKSJ-H';

 m_FontWidth      = '231 389 500 631 631 500';

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


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


constructor TPDFObjMemManager.Create(ObjectCount,ReallocCount word);
begin
  inherited Create;

  if (ObjectCount=0) or (ReallocCount= 0) then
   raise  EInvalidOperation.Create('!');

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

  ObjectPosArray :=buffer;
  if Buffer=nil then
     raise EOutOfMemory.Create('ƒپƒ‚ƒٹ‚ھ•s‘«‚µ‚ؤ‚¢‚ـ‚·پB');
end;

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

function TPDFObjMemManager.GetSize()word;
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])+' 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,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),Length(Lines));
              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) > MaxWidth then
             begin
                S :='';
                P :=Pchar(Lines);
                While not (P^=#0) do
                begin

                   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

                   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);

        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);

      MaxHeight:=m_PageHeight-m_MarginY*2;
      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

          PageText.Text:='';
          for j:= 0 to PageRows-1 do
          begin
             if k >=Lines.Count then break;
             PageText.Add(Lines[k]);
             Inc(k);
          end;
          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;


          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);


                 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;


          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;