Sources
Delphi Russian Knowledge Base
DRKB - это самая большая и удобная в использовании база знаний по Дельфи в рунете, составленная Виталием Невзоровым

Печать TStringGrid

01.01.2007
procedure TForm1.Button1Click(Sender: TObject);
var K: Double;
begin
 
Printer.BeginDoc;
 K
:=  Printer.Canvas.Font.PixelsPerInch / Canvas.Font.PixelsPerInch*1.2;
 
PrintStringGrid(StrGrid,
  K
,  // Коэффициент
 
200, // отступ от края листа в пихелах по Х
 
200, // --"-- по Y
 
200  // отступ снизу
 
);
 
Printer.EndDoc;
end;
{----------------------------------------------------------}
unit GrdPrn3
;
interface
uses
 
Windows, Classes, Graphics, Grids, Printers, SysUtils;
const
 
OrdinaryLineWidth: Integer = 2;
 
BoldLineWidth: Integer = 4;
procedure
PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin:
Integer);
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
 
// возвращает номер строки, которая не поместилась до Y = Yfloor
 
// не проверяет, вылезает ли общая длина таблицы за пределы страницы
 
// Слишком длинное слово обрежется
implementation
procedure
PrintStringGrid(Grid: TStringGrid; Scale: Double; LeftMargin,
TopMargin, BottomMargin: Integer);
var NextRow: Integer;
begin
 
//Printer.BeginDoc;
 
if not Printer.Printing then raise Exception.Create('function
 PrintStringGrid must be called between Printer.BeginDoc
   and Printer.EndDoc'
);
 
NextRow := 0;
 repeat
 
NextRow := DrawStringGridEx(Grid, Scale, NextRow, LeftMargin, TopMargin,
   
Printer.PageHeight - BottomMargin, Printer.Canvas);
 
if NextRow <> -1 then Printer.NewPage;
 
until NextRow = -1;
 
//Printer.EndDoc;
end;
function DrawStringGridEx(Grid: TStringGrid; Scale: Double; FromRow,
LeftMargin, TopMargin, Yfloor: Integer; DestCanvas: TCanvas): Integer;
 
// возвращает номер строки, которая не поместилась до Y = Yfloor
var
 i
, j, d, TotalPrevH, TotalPrevW, CellH, CellW, LineWidth: Integer;
 R
: TRect;
 s
: string;
  procedure
CorrectCellHeight(ARow: Integer);
 
// вычисление правильной высоты ячейки с учетом многострочного текста
 
// Текст рабивается только по словам слишком длинное слово обрубается
 
var
   i
, H: Integer;
   R
: TRect;
   s
: string;
 
begin
   R
:= Rect(0, 0, CellH*2, CellH);
   s
:= ':)'; // Одинарная высота строки
   
CellH := DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
     DT_LEFT
or DT_TOP or DT_WORDBREAK or DT_SINGLELINE or
     DT_NOPREFIX
or DT_CALCRECT) + 3*d;
   
for i := 0 to Grid.ColCount-1 do
   
begin
   
CellW := Round(Grid.ColWidths[i]*Scale);
    R
:= Rect(0, 0, CellW, CellH);
   
//InflateRect(R, -d, -d);
    R
.Left := R.Left+d;
    R
.Top := R.Top + d;
    s
:= Grid.Cells[i, ARow];
   
// Вычисление ширины и высоты
    H
:= DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
     DT_LEFT
or DT_TOP or DT_WORDBREAK or DT_NOPREFIX or DT_CALCRECT);
текста
   
if CellH < H + 2*d then CellH := H + 2*d;
   
// if CellW < R.Right - R.Left then Слишком длинное слово -
   
// не помещается в одну строку; Перенос слов не поддерживается
   
end;
 
end;
begin
 
Result := -1; // все строки уместились между TopMargin и Yfloor
 
if (FromRow < 0)or(FromRow >= Grid.RowCount) then Exit;
 
DestCanvas.Brush.Style := bsClear;
 
DestCanvas.Font := Grid.Font;
//  DestCanvas.Font.Height := Round(Grid.Font.Height*Scale);
 
DestCanvas.Font.Size := 10;
 
Grid.Canvas.Font := Grid.Font;
 
Scale := DestCanvas.TextWidth('test')/Grid.Canvas.TextWidth('test');
 d
:= Round(2*Scale);
 
TotalPrevH := 0;
 
for j := 0 to Grid.RowCount-1 do
 
begin
 
if (j >= Grid.FixedRows) and (j < FromRow) then Continue;
 
// Fixed Rows рисуются на каждой странице
 
TotalPrevW := 0;
 
CellH := Round(Grid.RowHeights[j]*Scale);
 
CorrectCellHeight(j);
 
if TopMargin + TotalPrevH + CellH > YFloor then
 
begin
   
Result := j; // j-я строка не помещается в заданный диапазон
   
if Result < Grid.FixedRows then Result := -1;
   
// если фиксированные строки не влезают на страницу -
   
// это тяж?лый случай...
   
Exit;
 
end;
 
for i := 0 to Grid.ColCount-1 do
 
begin
   
CellW := Round(Grid.ColWidths[i]*Scale);
   R
:= Rect(TotalPrevW, TotalPrevH, TotalPrevW + CellW,
     otalPrevH
+ CellH);
   
OffSetRect(R, LeftMargin, TopMargin);
   
if (i < Grid.FixedCols)or(j < Grid.FixedRows) then
     
LineWidth := BoldLineWidth
   
else
     
LineWidth := OrdinaryLineWidth;
   
DestCanvas.Pen.Width := LineWidth;
   
if LineWidth > 0 then
   
DestCanvas.Rectangle(R.Left, R.Top, R.Right+1, R.Bottom+1);
   
//InflateRect(R, -d, -d);
   R
.Left := R.Left+d;
   R
.Top := R.Top + d;
   s
:= Grid.Cells[i, j];
   
DrawText(DestCanvas.Handle, PChar(s), Length(s), R,
    DT_LEFT
or DT_TOP or DT_WORDBREAK or DT_NOPREFIX);
   
TotalPrevW := TotalPrevW + CellW; // Общая ширина всех предыдущих колонок
 
end;
 
TotalPrevH := TotalPrevH + CellH;  // Общая высота всех предыдущих строк
 
end;
end;
end.

Взято с https://delphiworld.narod.ru


Недавно довелось использовать код из "DRKB", для печати stringGrid, однако он не выводит на печать (у меня не вывел) 0-й столбец.
 
Я Переделал его, добавив прорисовку ячеек таблицы, более удобное расположение заголовка таблицы, в качестве параметров процедуре можно передать отступ от края и сверху листа в миллиметрах. Также снабдил код комментариями. (я сам новичёк в программировании, и будь в том коде комменты, разобрался бы куда легче чем пришлось).
 

Надеюсь кому нибудь пригодится...

procedure PrintGrid(sGrid: TStringGrid;
left_StandOff
,top_StandOff:integer; sTitle: string);
var
X1
, X2,PixelsX,PrinterCoordX: Integer;
Y1
, Y2,PixelsY,PrinterCoordY: Integer;
I
: Integer;
F
: Integer;
TR
: TRect;
begin
{ left_StandOff - отступ в миллиметрах слева от края листа
top_StandOff
- отступ в миллиметрах сверху от края листа
PrinterCoordX и PrinterCoordY - тот же отступ только в пикселах
Высота строк и ширина столбцов взяты соответственно 150 и 400,
при желании их размер можно передать в процедуру как параметры
}
//получаем информацию о разрешении принтера
PixelsX:=GetDeviceCaps(printer.Handle,LogPixelsX);//разрешение по Х
PixelsY:=GetDeviceCaps(printer.Handle,LogPixelsY);//разрешение по Y
PrinterCoordX:=round(PixelsX/25.4*left_StandOff);//переводим мм в пиксели
PrinterCoordY:=round(PixelsY/25.4*top_StandOff); //---
with printer do
begin
//Печатаем заголовок таблицы
Title := sTitle;
BeginDoc; // Начало печати
Canvas.Pen.Color := 0; // цвет-чёрный
Canvas.Font.Name := 'verdana'; // шрифт
Canvas.Font.Size := 10; // размер шрифта
Canvas.Font.Style := [];
//Текс заголовка в заданных координатах
Canvas.TextOut(PrinterCoordX, PrinterCoordY-100-
printer
.Canvas.Font.Size*10, Printer.Title);
Canvas.Pen.Color := 0;
Canvas.Font.Name := 'Verdana';
Canvas.Font.Size := 8;
end;
for i:=0 to sgrid.colcount-1 do //перебираем столбцы
for f:=0 to sgrid.rowcount-1 do //перебираем в столбце все строки
begin
X1
:= PrinterCoordX+i*400; //400-это ширина столбца
X2
:= PrinterCoordX+400+i*400; //тоже
Y1
:=PrinterCoordY+f*150; //150-высота строки
y2
:=PrinterCoordY+150+f*150; //тоже
TR
:=Rect(x1,y1,x2,y2);
with printer do
begin
Canvas.MoveTo(x1,y1);//Двигаем рисовалку в верхний левый угол таблицы
{пишем надпись в квадрате(ячейке) i-столбеца и f-строки со сдвигом
от верха на Y+50 и со сдвигом от левого края колонки на X+50
}
Canvas.TextRect(TR, X1 + 50, Y1 + 50, sGrid.Cells[i,f]);
//рисуем линии ячейки
Canvas.LineTo(x1,y2);
Canvas.LineTo(x2,y2);
Canvas.LineTo(x2,y1);
Canvas.LineTo(x1,y1);
end;
end;
Printer.EndDoc; // конец печати
end;
 
 
procedure TForm1
.Button1Click(Sender: TObject);
begin
PrintGrid(StringGrid1,20,20, 'Таблица1: "Название"');
end;

Автор: pankerstein

Взято с Vingrad.ru https://forum.vingrad.ru