没有刷子样式的字符串网格打印

Question

我在打印字符串网格时遇到问题。我使用此代码，除了画笔样式外效果很好。在应用程序中它工作 - 在单元格中是 'XXXX'，它被 brush.style:= bsDiagCross; 覆盖但是当我尝试打印它时，画笔样式消失并且在打印页面上是 table 和 '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 := 3333;
                   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;

Answer 1

在打印代码 (frmPrint.Gridd()) 中，您缺少对 'XXXX' 的检查和 Brush.Style 的相应设置并调用 FillRect() 而不是调用 DrawText().

在第二个 for x 循环中的 frmPrint.Gridd() 中更改此行：

        DrawText(Canvas.Handle, PChar(grd.Cells[x, y]), length(grd.Cells[x, y]), r,
          DT_SINGLELINE or DT_VCENTER);

至（未测试）：

        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;

如果 header 行也可能有那些 'XXXX' 单元格，那么也在第一个 for x 循环中进行相应的更改。

Answer 2

汤姆，非常感谢你的帮助！！解决方案是在 draw 后面交换刷块这非常有效：

...
DrawText(Canvas.Handle, PChar(Grd.Cells[x,y]), length(Grd.Cells[x,y]), r, DT_SINGLELINE or DT_VCENTER);

li := re;
if grd.Cells[x, y] = 'XXXX' then
  begin
    Canvas.Brush.Style := bsDiagCross;
    Canvas.FillRect(r);
    Canvas.Brush.Style := bsClear;
  end;

没有刷子样式的字符串网格打印

String grid prints with no brush style

printing

delphi

stringgrid

delphi-xe7