Процедура печати TStringList на принтер
Процедура печатает TStringList на принтер, переносит на следующий лист бумаги, если список не помещается.
Поля - фиксированные в пол-дюйма.
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;
Алексей Еремеев
Смотрите так же:
