How to change the printer resolution

Problem/Question/Abstract:

I'm trying to change the print resolution of TPrinter from my application. But it works only if I change this parameter in a TPrintDialog. Commands like "Printer.Canvas.Font.PixelsPerInch := NewResolution" don't work.

Answer:

The first step is to find out which resolutions the printer supports. You do that via Winspool.Devicecapabilities. You select one of the available settings and the modify two fields of the printers devmode structure accordingly.

Create a new project, drop a TRadiogroup and a TButton on it, leave the radiogroup empty. Add handlers for the forms OnCreate event and the buttons OnClick.

uses
  winspool, Printers;

{$R *.DFM}

type
  TPrinterResolution = record
    resx, resY: Longint;
  end;
  TPrinterResolutions = array of TPrinterResolution;

function GetPrinterResolutions: TPrinterResolutions;
var
  numResolutions: Integer;
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numResolutions := WinSpool.DeviceCapabilities(Device, Port, DC_ENUMRESOLUTIONS, nil,
    nil);
  SetLength(Result, numResolutions);
  if numResolutions > 0 then
  begin
    WinSpool.DeviceCapabilities(Device, Port, DC_ENUMRESOLUTIONS, @Result[0], nil);
  end;
end;

procedure TForm1.FormCreate(Sender: TObject);
var
  resarray: TPrinterResolutions;
  i: Integer;
begin
  resArray := GetPrinterResolutions;
  for i := 0 to Length(resarray) - 1 do
  begin
    {create a radiobutton for each resolution, pack the actual resolution into
                        its Tag property}
    radiogroup1.Items.add(format('%d x %d dpi', [resarray[i].resX,
      resarray[i].resY]));
    radiogroup1.Controls[i].Tag := MakeLong(LoWord(resarray[i].resX),
      LoWord(resarray[i].resY));
  end;
  if radiogroup1.items.count > 0 then
  begin
    radiogroup1.itemindex := 0;
    radiogroup1.clientheight := radiogroup1.ControlCount *
      radiogroup1.controls[0].height;
  end
  else
    button1.enabled := false;
end;

procedure TForm1.Button1Click(Sender: TObject);
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  pDevMode: PDeviceMode;
  dw: DWORD;
begin
  with radiogroup1 do
    dw := Controls[itemindex].Tag;
  {test print using selected resolution}
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  {force reset of devmode}
  Printer.SetPrinter(Device, Driver, Port, 0);
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  if hDevmode <> 0 then
  begin
    pDevmode := GlobalLock(hDevmode);
    if pDevmode <> nil then
    try
      pDevMode^.dmPrintQuality := LoWord(dw);
      pDevmode^.dmYResolution := HiWord(dw);
      pDevmode^.dmFields := pDevmode^.dmFields or DM_PRINTQUALITY or DM_YRESOLUTION;
    finally
      GlobalUnlock(hDevmode);
    end;
    Printer.beginDoc;
    try
      with Printer.Canvas.Font do
      begin
        Name := 'Arial';
        Size := 24;
      end;
      {print test string 1 inch from margins}
      Printer.Canvas.textOut(LoWord(dw), HiWord(dw), 'This is a test');
    finally
      Printer.endDoc;
    end;
  end;
end;