Delphi 更改BSB对角线线宽和间距

我正在尝试在高DPI和标准DPI环境中生成一致的接口。我们有一个选择框，其中包含使用类似以下内容的绘画：

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

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;

是否有任何方法可以更改BSB对角线绘制的线条宽度和线条之间的间距，因为这些不考虑显示器的DPI。使用高DPI系统的用户将看到非常细的对角线，这些对角线非常靠近，而使用常规DPI监视器的用户将看到距离更远、更宽的绘画

比如说。左边的一个是常规DPI监视器上的用户将看到的，右边的一个是高DPI等效值

---

图案填充笔刷始终在图形设备单元中工作。我在旧时代遇到打印机问题，并执行以下步骤：

//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;

//填充步长与DPI呈线性关系
程序PrintHatchPolygon（画布：TCanvas；Pts:TPoint数组；
FillStep：整数）；
变量
ClipRgn:HRGN；
r:TRect；
i、 MaxSize、OldPenColor、HatchStyle:整数；
程序行（X1，Y1，X2，Y2：整数）；
开始
Canvas.MoveTo（X1，Y1）；
Canvas.LineTo（X2，Y2）；
结束；
开始
case Canvas.Brush.Style of
垂直方向：
舱口样式：=1；
水平方向：
舱口样式：=2；
BSF对角线：
舱口样式：=4；
BSB对角线：
舱口样式：=8；
bsCross：
舱口样式：=3；
bsDiagCross：
舱口样式：=12；
其他的
HatchStyle:=0；
结束；
OldPenColor:=Canvas.Pen.Color；
Canvas.Pen.Color:=Canvas.Brush.Color；
ClipRgn:=CreatePolygonRgn（分，高（分）+1，交替）；
GetRgnBox（ClipRgn，r）；
最大尺寸：=r.底部-r.顶部；
如果MaxSize<（右-左）则
MaxSize:=r.右-r.左；
选择ClipRgn（Canvas.Handle，ClipRgn）；
用r开始
如果（HatchStyle和1）>0，则
对于i:=1到（右-左）div FillStep do
行（左+i*填充步骤，顶部，左+i*填充步骤，底部）；
如果（HatchStyle和2）>0，则
对于i:=1到（r.Bottom-r.Top）div FillStep do
行（左、上+i*FillStep、右、上+i*FillStep）；
//均衡步长
//FillStep:=1414*FillStep div 1000；
如果（HatchStyle和4）>0，则
对于i:=1到2*MaxSize div FillStep do
行（左，底部-i*FillStep，左+i*FillStep，底部）；
如果（HatchStyle和8）>0，则
对于i:=1到2*MaxSize div FillStep do
行（左，顶部+i*FillStep，左+i*FillStep，顶部）；
结束；
选择cliprgn（Canvas.Handle，0）；
DeleteObject（ClipRgn）；
Canvas.Pen.Color:=旧铅笔颜色；
结束；
程序TForm1.按钮7单击（发送方：TObject）；
变量
P:TPoint的数组[0..2]；
开始
P[0]：=第（10,10）点；
P[1]：=点（100,10）；
P[2]：=点（10200）；
Canvas.Brush.Style:=bsDiagCross；
Canvas.Brush.Color:=clRed；
//普通监视器dpi的值8（72？）
//600dpi打印机的值为60
PrintHatchPolygon（画布，第8页）；
Canvas.Brush.Style:=bsClear；
多边形（P）；
结束；

另一种选择是使用自定义笔刷。我无法使自定义笔刷选项与透明度一起工作

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;

绘画应该是这样的：

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

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;

---

可能是自定义画笔位图。@LURD我尝试过使用自定义画笔位图。刷子的透明度似乎有问题。至少我不能让它工作。不过，我会就此提出另一个问题。我担心这种方法会比使用刷子慢。我使用了你的一些代码来获得一个自定义笔刷选项，但无法使用它获得透明度。在我看来，这是唯一的办法，如果你想在孵化透明度。