Распечатать TStrings на принтере по умолчанию

Советы » Принтеры и Печать » Распечатать TStrings на принтере по умолчанию

procedure PrintStrings(S: TStrings; Font: TFont; Title: string
);
var

 LeftMargin, TopMargin, LineCoord, LineOnPage, LinesOnDoc,
 CurrentLine, TextHeight, LinesPerPage, LineInterval: integer;

 procedure
 StartDoc;
 begin

   LinesOnDoc := S.Count;
   Printer.Canvas.Font.Assign(Font);
   Printer.Canvas.TextOut(0, 0, ' ');
   LeftMargin := (Printer.Canvas.Font.PixelsPerInch) div
 2;
   TopMargin  := (Printer.Canvas.Font.PixelsPerInch) div
 2;
   TextHeight := Abs(Printer.Canvas.Font.Height);
   LineInterval := TextHeight + (TextHeight div
 2);
   LinesPerPage := (Printer.PageHeight - TopMargin) div
 LineInterval;
   CurrentLine := 0;
 end
;

 function
 MorePages:boolean;
 begin

   Result := (CurrentLine <  LinesOnDoc) and

             not
 Printer.Aborted;
 end
;

 procedure
 StartPage;
 begin

   LineOnPage := 0;
   LineCoord := TopMargin;
 end
;

 procedure
 NextPage;
 begin

   if
 MorePages then
 Printer.NewPage;
 end
;

 function
 MoreLines:boolean;
 begin

   Result := (LineOnPage <  LinesPerPage) and

             (LineOnPage <  LinesOnDoc) and

             not
 Printer.Aborted;
 end
;

 procedure
 NextLine;
 begin

   Inc(LineOnPage);
   Inc(LineCoord, LineInterval);
   Inc(CurrentLine);
 end
;

 procedure
 PrintLine;
 begin

   Printer.Canvas.TextOut(LeftMargin, LineCoord, S.Strings[CurrentLine]);
 end
;

begin

 Printer.Title := Title;
 Printer.BeginDoc;
 StartDoc;
 while
 MorePages do

 begin

   StartPage;
   while
 MoreLines do

   begin

     PrintLine;
     NextLine;
     Application.ProcessMessages;
   end
;
   NextPage;
 end
;
 Printer.EndDoc;
end
;

Распечатать TStrings на принтере по умолчанию

Другое по теме:

Категории

Статьи

Советы