I am having trouble with printing string grid. I use this code which works good except brush style. In application it works - where in cell is 'XXXX', it is overwritten with brush.style:= bsDiagCross; But when I try to print it, brush style is gone and on printed page is table with 'XXXX'. What´s wrong?
procedure frmPrint.Gridd(grd:TStringGrid; links, oben: Integer; scal:double; farbig:boolean);
var
x, y, li, ob, re, un, waag, senk, a, vSpalte, bSpalte, vZeile, bZeile: integer;
fix, grund, schrift, Barva: TColor;
r: TRect;
RR: TRect;
Sirka,Vyska, Velikost : integer;
function rech(i,j:integer):integer;
begin
result:=round(((i*j) / 72) * scal);
end;
begin
if printdialog.execute then // offnet den print dialog
begin
vZeile := 0;
vSpalte := 0;
Sirka := Printer.PageWidth;
Vyska := Printer.PageHeight;
bZeile := grd.rowcount - 1;
bSpalte := grd.colcount - 1;
if (scal > 0) and
(vZeile < grd.rowcount) and
(vSpalte < grd.colcount) then
begin
if farbig then
begin
fix := grd.fixedcolor;
grund := grd.color;
schrift := grd.font.color;
end
else
begin
fix := clsilver;
grund := clwhite;
schrift := clblack;
end;
waag := GetDeviceCaps(Printer.Handle, LogPixelSX);
senk := GetDeviceCaps(Printer.Handle, LogPixelSY);
links := rech(links, waag);
oben := rech(oben, senk);
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
a := rech(3, waag);
with Printer do
begin
Title := 'report';
Orientation := poLandscape; //poLandscape;
BeginDoc;
if grd.gridlinewidth > 0 then
begin
Canvas.Pen.color := $333333;
Canvas.Pen.width := 1;
Canvas.Pen.Style := psSolid
end
else
Canvas.Pen.Style := psClear;
Canvas.Font := Grd.Font;
Canvas.Font.Color := Schrift;
Canvas.Font.Size := round((Grd.Font.Size / 0.72) * scal);
ob := GetDeviceCaps(Printer.Handle, PhysicalOffsetY) + 1 + oben;
for y := vZeile to bZeile do
begin
un := ob + rech(Grd.RowHeights[y]+1, senk);
//neue Seite + Kopf
if (un > Printer.PageHeight) and
(Printing) then
begin
EndDoc;
BeginDoc;
ob := GetDeviceCaps(Printer.Handle, PhysicalOffsetY) + 1 + oben;
un := ob + rech(Grd.RowHeights[y]+1, senk);
for x := vSpalte to bSpalte do
begin
Canvas.Brush.Color := fix;
re := li + rech(Grd.ColWidths[x] + 1, waag);
Canvas.Rectangle(li, ob, re + 2, un + 2);
r := rect(li + a, ob + 1, re - a, un - 2);
DrawText(Canvas.Handle, PChar(Grd.Cells[x,0]), length(Grd.Cells[x,0]), r, DT_SINGLELINE or DT_VCENTER);
li := re;
end;
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
ob := un;
end;
un := ob + rech(Grd.RowHeights[y]+1, senk);
for x := vSpalte to bSpalte do
begin
if (x < Grd.FixedCols) or
(y < Grd.FixedRows) then
Canvas.Brush.Color := fix
else
Canvas.Brush.Color := Grund;
re := li + rech(Grd.ColWidths[x]+ 1, waag);
Canvas.Rectangle(li, ob, re + 2, un + 2);
r := rect(li + a, ob + 1, re - a, un - 2);
DrawText(Canvas.Handle, PChar(Grd.Cells[x,y]), length(Grd.Cells[x,y]), r, DT_SINGLELINE or DT_VCENTER);
li := re;
end;
ob := un;
li := GetDeviceCaps(Printer.Handle, PhysicalOffsetX) + 1 + links;
end;
if Printing then
EndDoc;
end;
end;
end;
end;
procedure frmPrint.sgDrawCell(Sender: TObject; ACol, ARow: Integer; Rect: TRect;
State: TGridDrawState);
var
sg : TStringGrid;
c : TCanvas;
begin
sg := TStringGrid( Sender );
c := sg.Canvas;
if // Zellen
( sg.Cells[ACol,ARow] = 'XXXX' )
then begin
c.Brush.Style := bsDiagCross;
c.FillRect(Rect);
// c.Brush.Color := clblack;
end;
sg.Canvas.Pen.Color := clblack;
// "Set the Style property to bsClear to eliminate flicker when the object
// repaints" (I don't know if this helps).
sg.Canvas.Brush.Style := bsClear;
// Draw a line from the cell's top-right to its bottom-right:
sg.Canvas.MoveTo(Rect.Right, Rect.Top);
sg.Canvas.LineTo(Rect.Right, Rect.Bottom);
// Make the horizontal line.
sg.Canvas.LineTo(Rect.Left, Rect.Bottom);
// The other vertical line.
sg.Canvas.LineTo(Rect.Left, Rect.Top);
zmeneno:= false;
end;
In the printing code (frmPrint.Gridd()) you are missing the check for 'XXXX' and corresponding setting of Brush.Style and call to FillRect() instead of the call to DrawText().
In frmPrint.Gridd() in the second for x loop change this line:
DrawText(Canvas.Handle, PChar(grd.Cells[x, y]), length(grd.Cells[x, y]), r,
DT_SINGLELINE or DT_VCENTER);
to (untested):
if grd.Cells[x, y] = 'XXXX' then
begin
Canvas.Brush.Style := bsDiagCross;
Canvas.FillRect(r);
Canvas.Brush.Style := bsClear;
end
else
begin
DrawText(Canvas.Handle, PChar(grd.Cells[x, y]), length(grd.Cells[x, y]), r,
DT_SINGLELINE or DT_VCENTER);
end;
If the header row also may have those 'XXXX' cells then do the corresponding change also in the first for x loop.