更改 bsBDiagonal 线宽和间距

Question

我试图在高 DPI 和标准 DPI 环境中生成一致的界面。我们有一个选择框，使用类似这样的绘画：

theCanvas.Brush.style := bsBDiagonal;
theCanvas.pen.style := psClear;
theCanvas.brush.color := clBlue;

有什么方法可以更改 bsBDiagonal 绘制的线条宽度和线条之间的间隙，因为这些没有考虑显示器的 DPI。使用高 DPI 系统的用户会看到非常细的对角线，这些对角线靠得很近，而使用普通 DPI 显示器的用户会看到距离更远、更宽的绘画。

例如。左边的是普通 DPI 显示器上的用户将看到的内容，右边的是高 DPI 显示器的等效内容。

Answer 1

填充笔刷始终以图形设备单位工作。我以前用打印机遇到过这个问题，做了这个程序：

//Fillstep depends linearly on DPI

procedure PrintHatchPolygon(Canvas: TCanvas; Pts: array of TPoint;
  FillStep: Integer);
var
  ClipRgn: HRGN;
  r: TRect;
  i, MaxSize, OldPenColor, HatchStyle: Integer;

  procedure Line(X1, Y1, X2, Y2: Integer);
  begin
    Canvas.MoveTo(X1, Y1);
    Canvas.LineTo(X2, Y2);
  end;

begin
  case Canvas.Brush.Style of
    bsVertical:
      HatchStyle := 1;
    bsHorizontal:
      HatchStyle := 2;
    bsFDiagonal:
      HatchStyle := 4;
    bsBDiagonal:
      HatchStyle := 8;
    bsCross:
      HatchStyle := 3;
    bsDiagCross:
      HatchStyle := 12;
  else
    HatchStyle := 0;
  end;
  OldPenColor := Canvas.Pen.Color;
  Canvas.Pen.Color := Canvas.Brush.Color;
  ClipRgn := CreatePolygonRgn(Pts, High(Pts) + 1, ALTERNATE);
  GetRgnBox(ClipRgn, r);
  MaxSize := r.Bottom - r.Top;
  if MaxSize < (r.Right - r.Left) then
    MaxSize := r.Right - r.Left;
  SelectClipRgn(Canvas.Handle, ClipRgn);
  with r do begin
    if (HatchStyle and 1) > 0 then
      for i := 1 to (r.Right - r.Left) div FillStep do
        Line(Left + i * FillStep, Top, Left + i * FillStep, Bottom);
    if (HatchStyle and 2) > 0 then
      for i := 1 to (r.Bottom - r.Top) div FillStep do
        Line(Left, Top + i * FillStep, Right, Top + i * FillStep);

    //to equalize step
    //FillStep := 1414 * FillStep div 1000;

    if (HatchStyle and 4) > 0 then
      for i := 1 to 2 * MaxSize div FillStep do
        Line(Left, Bottom - i * FillStep, Left + i * FillStep, Bottom);
    if (HatchStyle and 8) > 0 then
      for i := 1 to 2 * MaxSize div FillStep do
        Line(Left, Top + i * FillStep, Left + i * FillStep, Top);
  end;
  SelectClipRgn(Canvas.Handle, 0);
  DeleteObject(ClipRgn);
  Canvas.Pen.Color := OldPenColor;
end;

procedure TForm1.Button7Click(Sender: TObject);
var
  P: array [0 .. 2] of TPoint;
begin
  P[0] := Point(10, 10);
  P[1] := Point(100, 10);
  P[2] := Point(10, 200);
  Canvas.Brush.Style := bsDiagCross;
  Canvas.Brush.Color := clRed;

  //value 8 for usual monitor dpi (72?)
  //value 60 for 600dpi printer
  PrintHatchPolygon(Canvas, P, 8);
  Canvas.Brush.Style := bsClear;
  Canvas.Polygon(P);
end;

Answer 2

另一种方法是使用自定义画笔。我无法获得使用透明度的自定义画笔选项。

procedure SetupHatchBitmapBrush(ABitmap: TBitmap; const ABrushStyle:
    TBrushStyle; const AFillStep: Integer; const APenColor: TColor);
var
  bitmapSize: TSize;
  rect: TRect;
  cntr: Integer;
  maxSize: Integer;
  oldPenColor: Integer;
  hatchStyle: Integer;

  procedure Line(bBitmap: TBitmap; bX1, bY1, bX2, bY2: Integer);
  begin
    bBitmap.Canvas.MoveTo(bX1, bY1);
    bBitmap.Canvas.LineTo(bX2, bY2);
  end;

begin
  case ABrushStyle of
    bsVertical:   hatchStyle := 1;
    bsHorizontal: hatchStyle := 2;
    bsFDiagonal:  hatchStyle := 4;
    bsBDiagonal:  hatchStyle := 8;
    bsCross:      hatchStyle := 3;
    bsDiagCross:  hatchStyle := 12;
  else
    hatchStyle := 0;
  end;

  oldPenColor := ABitmap.Canvas.Pen.Color;
  try
    ABitmap.Canvas.Pen.Color := APenColor;

    maxSize := ABitmap.Height;
    if maxSize < ABitmap.Width then
      maxSize := ABitmap.Width;
    if (hatchStyle and 1) > 0 then
      for cntr := 1 to ABitmap.Width div AFillStep do
        Line(ABitmap, cntr * AFillStep, 0, cntr * AFillStep, ABitmap.Height);
    if (hatchStyle and 2) > 0 then
      for cntr := 1 to ABitmap.Height div AFillStep do
        Line(ABitmap, 0, cntr * AFillStep, ABitmap.Width, cntr * AFillStep);

    if (hatchStyle and 4) > 0 then
      for cntr := 1 to 2 * maxSize div AFillStep do
        Line(ABitmap, 0, ABitmap.Height - cntr * AFillStep, cntr * AFillStep, ABitmap.Height);
    if (hatchStyle and 8) > 0 then
      for cntr := 1 to 2 * maxSize div AFillStep do
        Line(ABitmap, 0, cntr * AFillStep, cntr * AFillStep, 0);
  finally
    ABitmap.Canvas.Pen.Color := oldPenColor;
  end;
end;

function CreatePatternBitmap(const ABrushStyle: TBrushStyle; const APenColor,
    ABackgroundColor: TColor; const AScaleFactor: Double): TBitmap;
const
  DEFAULT_SIZE = 8;
var
  bitmapStep: Integer;
begin
  bitmapStep := Trunc(DEFAULT_SIZE * AScaleFactor);
  Result := TBitmap.Create;
  Result.Canvas.Brush.Color := clWhite;
  Result.Canvas.Brush.Style := bsSolid;
  Result.PixelFormat := pf32bit;
  Result.SetSize(bitmapStep * 2, bitmapStep * 2);

  SetupHatchBitmapBrush(Result, ABrushStyle, bitmapStep, APenColor);
end;

有时我们需要创建位图。

begin
  FBitmap := CreatePatternBitmap(bsBDiagonal, clRed, clWhite, 1.5);
end;

绘画看起来像这样：

begin
  Canvas.Brush.Color := clBlue;
  Canvas.Pen.Style := psClear;
  Canvas.Brush.style := bsBDiagonal;
  Canvas.Brush.Bitmap := FBitmap;
  Canvas.Rectangle(Rect(10, 10, 100, 100));
end;

更改 bsBDiagonal 线宽和间距

Changing the bsBDiagonal line width and gaps

delphi

delphi-xe7