Druck in TMetafile > (manchmal) fehlerhafte Textdarstellung

[bernau]

In manchen Situationen zeichne ich einen Text nicht direkt auf den Canvas, sondern ich zeichne erst einmal in ein TMetafile und dieses wird bei Bedarf auf den Canvas gezeichnet. Nun habe ich 2 Fälle in denen der Text nicht korrekt dargestellt wird. Das passiert aber nur auf dem Computer des Kunden (Zwei verschiedene Kunden).

Am Programm dürfte es nicht liegen, da die Darstellung eigentlich immer OK ist. Bis auf diese 2 Computer (Win11).

Ich habe mal ein kleines Testprogramm geschrieben, mit dem ich den Fehler darstellen kann.

Delphi-Quellcode:

unit ccMetafileTest.Hf;

interface

uses
  Winapi.Windows,
  Winapi.Messages,
  System.SysUtils,
  System.Variants,
  System.Classes,
  Vcl.Graphics,
  Vcl.Controls,
  Vcl.Forms,
  Vcl.Dialogs,
  Vcl.ExtCtrls;

type
  TFormMetafileTest = class(TForm)
    PaintBox1: TPaintBox;
    procedure PaintBox1Paint(Sender: TObject);
  private
    function PaintTextToCanvas(const aCanvas: TCanvas; const aX, aY: Integer; const aFontName:String): TRect;
    Procedure PaintAll(const aCanvas: TCanvas);
  public

  end;

var
  FormMetafileTest: TFormMetafileTest;

implementation

{$R *.dfm}

procedure TFormMetafileTest.PaintBox1Paint(Sender: TObject);
begin
  PaintAll(PaintBox1.Canvas);
end;

procedure TFormMetafileTest.PaintAll(const aCanvas: TCanvas);
var
  lMetafile: TMetafile;
  lMetafileCanvas: TMetafileCanvas;
  lRect:TRect;
begin
  //***************************************************
  // Direkt auf den Canvas zeichnen (Test oben Links)
  PaintTextToCanvas(aCanvas, 0, 0,'Arial');
  //***************************************************
  // Direkt auf den Canvas zeichnen (Test oben Rechts)
  PaintTextToCanvas(aCanvas, 300, 0,'Courier New');

  //***************************************************
  // Umweg über TMetafile (Text unten links)
  lMetafile := TMetafile.Create;
  lMetafile.SetSize(1000,1000);

  lMetafileCanvas := TMetafileCanvas.Create(lMetafile,acanvas.Handle);
  lRect := PaintTextToCanvas(lMetafileCanvas, 0, 0,'Arial');
  lMetafileCanvas.Free;

  lRect := Trect.Create(TPoint.Create(0,70),1000,1000);
  aCanvas.StretchDraw(lRect, lMetaFile);
  lMetafile.Free;

  //***************************************************
  // Umweg über TMetafile (Text unten Rechts)
  lMetafile := TMetafile.Create;
  lMetafile.SetSize(1000,1000);

  lMetafileCanvas := TMetafileCanvas.Create(lMetafile,acanvas.Handle);
  lRect := PaintTextToCanvas(lMetafileCanvas, 0, 0,'Courier New');
  lMetafileCanvas.Free;

  lRect := Trect.Create(TPoint.Create(300,70),1000,1000);
  aCanvas.StretchDraw(lRect, lMetaFile);
  lMetafile.Free;
end;

function TFormMetafileTest.PaintTextToCanvas(const aCanvas: TCanvas; const aX, aY: Integer; const aFontName:String): TRect;
var
  lText:String;
begin
  lText :='ABCDEabcde';
  aCanvas.font.name := aFontName;
  aCanvas.font.Height := 50;

  Result.Left :=aX;
  Result.Top :=aY;

  Result.Width := aCanvas.TextWidth(lText);
  Result.Height := aCanvas.TextHeight(lText);

  aCanvas.Brush.Style := bsSolid;
  aCanvas.Brush.Color := clRed;
  aCanvas.Rectangle(aX, aY, aX + Result.Width, aY + Result.Height);

  aCanvas.Brush.Style := bsClear;
  aCanvas.TextOut(aX, aY, lText);
end;

end.

In den Anhängen sieht man einmal die korrekte Darstellung und einmal die Fehlerhafte Darstellung. Die oberen zwei Texte werden immer korrekt dargestellt, weil direkt auf den Canvas gezeichnet wird. Die unteren beiden Text sind einmal korrekt und einmal fehlerhaft.

Ich dachte zuerst, es liegt an einem fehlerhaften Font (beim Kunde). Deshalb jeweils zwei Texte mit unterschiedlichem Font um diese Annahme auszuschliessen. Dann dachte ich, es liegt an der Bildschirmscalierung (150%). Fehlanzeige.

Bin mir sehr sicher, dass es an eine dummen Einstellung des Computers liegt. Aber wo soll ich suchen?