文字列グリッドの印刷に問題があります。ブラシスタイル以外はうまく機能するこのコードを使用します。アプリケーションでは機能します-セルが「XXXX」の場合、上書きされますbrush.style:= bsDiagCross;しかし、印刷しようとすると、ブラシスタイルがなくなり、印刷されたページに「XXXX」の表があります。どうしたの？
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;