unit PrintGrid; 

interface 

uses 
  Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 
  Grids, Printers; 

type 
    TPrintGrid = class(TStringGrid) 
    private 
           FPrintAborted:boolean; 
    protected 
    public 
    procedure PrintGrid; 
    published 
  end; 

procedure Register; 

implementation 

procedure TPrintGrid.PrintGrid; 
var 
   margins: trect; 
   spacing: integer; 
   cols: tlist; 

   procedure setcolumnwidth; 
   var 
      i, k, w: integer; 
   begin 
        Printer.Canvas.Font.Style := [ fsBold ]; 
        for i := 0 to pred( ColCount ) do 
            Cols.Add(Pointer(Printer.Canvas.TextWidth(cells[i,0]))); 
            printer.canvas.font.style := []; 
            for i := 1 to pred(rowcount ) do 
                for k := 0 to pred(colcount ) do 
                begin 
                     w:= printer.canvas.textwidth( cells[ k, i ] ); 
                     if w  integer( cols[ k ] ) then 
                        cols[ k ] := pointer( w ); 
                end; 
                w := 2 * printer.canvas.font.pixelsperinch div 3; 
                margins :=rect( w, w, printer.pagewidth-w, printer.pageheight - w ); 
                spacing := printer.canvas.font.pixelsperinch div 10; 
                w := 0; 
                for i := 0 to pred(cols.count) do 
                    w := w + integer( cols[ i ] ) + spacing; 
                    w := w - spacing; 
                    if w  (margins.right-margins.left ) then 
                    begin 
                         w := w - (margins.right-margins.left ); 
                         cols[ cols.count-2 ] :=pointer( integer( cols[ cols.count-2 ] ) - w ); 
                    end; { if } 
                    w:= 0; 
                    for i := 0 to pred(cols.count) do 
                        w := w + integer( cols[ i ] ) + spacing; 
                        margins.right := w - spacing + margins.left; 
   end; { setcolumnwidth } 

   procedure doprint; 
   var 
      i: integer; 
      y: integer; 

      procedure doline(lineno: integer); 
      var 
         x, n: integer; 
         r: trect; 
         th: integer; 
      begin 
           if length(cells[1,lineno]) = 0 then exit; 
              x:= margins.left; 
              with printer.canvas do 
              begin 
                   th := textheight( 'Äy' ); 
                   for n := 0 to pred( cols.count ) do 
                   begin 
                        r := rect( 0, 0, integer(cols[ n ]), th); 
                        offsetrect( r, x, y ); 
                        textrect( r, x, y, cells[ n, lineno ] ); 
                        x := r.right + spacing; 
                   end; { for } 
              end; { with } 
              y := y + th; 
      end; { doline } 

      procedure doheader; 
      begin 
           y := margins.top; 
           with printer.canvas do 
           begin 
                font.style := [ fsbold ]; 
                doline( 0 ); 
                pen.width := font.pixelsperinch div 72; 
                pen.color := clblack; 
                moveto( margins.left, y ); 
                lineto( margins.right, y ); 
                inc( y, 2 * pen.width ); 
                font.style := [ ]; 
           end; { with } 
      end; { doheader } 

      begin 
           y:= 0; 
           for i := 1 to pred( rowcount ) do 
           begin 
                application.processmessages; 
                if fprintaborted then 
                   exit; 
                   if y = 0 then 
                      doheader; 
                      doline( i ); 
                      if y = margins.bottom then 
                      begin 
                           printer.newpage; 
                           y:= 0; 
                      end; { if } 
           end; { for } 
      end; { doprint } 

      begin 
           fprintaborted := false; 
           try 
              show; 
              application.processmessages; 
              if printer.printing then 
                 {$ifdef win32} 
                 printer.abort; 
                 {$else} 
                 abortdoc( printer.canvas.handle ); 
                 {$endif} 
                 printer.begindoc; 
                 cols:= nil; 
                 try 
                    cols:= tlist.create; 
                    {$ifndef win32} 
                    printer.canvas.font.pixelsperinch := 
                    getdevicecaps( printer.handle, logpixelsy ); 
                    {$endif} 
                    printer.canvas.font.assign( font ); 
                    printer.canvas.font.color :=clblack; 
                    printer.canvas.pen.color := clblack; 
                    setcolumnwidth; 
                    application.processmessages; 
                    doprint; 
                    finally 
                           cols.free; 
                           if fprintaborted then 
                              {$ifdef win32} 
                              printer.abort 
                              {$else} 
                              abortdoc( printer.canvas.handle ) 
                              {$endif} 
                           else 
                               printer.enddoc; 
      end; 
      finally 
      begin 
      end; 
   end; 
end; { with } 


procedure Register; 
begin 
  RegisterComponents('PrintGrid', [TPrintGrid]); 
end; 

end.