Aktuelles Papierformat auslesen/setzen?

[PeterPanino]

Eureka - nach vielen Stunden Recherche habe ich endlich eine Lösung zusammengebastelt, die funktioniert:

Delphi-Quellcode:

type
  TPaperName = array[0..63] of Char;
  TPaperInfo = packed record
    papername: TPapername;
    paperID: Word;
    papersize: TPoint;
  end;
  TPaperInfos = array of TPaperInfo;
  TPaperSizes = array of TPoint;

function GetPaperID: SmallInt;
var
  Device, Driver, Port: array[0..127] of char;
  hDeviceMode: THandle;
  pDevMode: PDeviceMode;
begin
  with Printer do
  begin
    GetPrinter(Device, Driver, Port, hDeviceMode);
    pDevMode := GlobalLock(hDevicemode);
    if pDevMode <> nil then
    try
      with pDevMode^ do
      begin
        dmFields := dmFields or DM_PAPERSIZE;
        Result := dmPapersize;
      end;
    finally
      GlobalUnlock(hDevicemode);
    end;
  end;
end;

procedure GetPapernames(sl: TStrings; index: Integer);
type
  TPaperNameArray = array[1..High(Integer) div Sizeof(TPaperName)] of TPaperName;
  PPapernameArray = ^TPaperNameArray;
  TPaperArray = array[1..High(Integer) div Sizeof(Word)] of Word;
  PPaperArray = ^TPaperArray;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numPaperNames, numPapers, temp: Integer;
  pPaperNames: PPapernameArray;
  pPapers: PPaperArray;
begin
  Assert(Assigned(sl));
  Printer.PrinterIndex := index;
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPaperNames := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, nil, nil);
  numPapers := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, nil, nil);
  if numPapers <> numPaperNames then
  begin
    raise Exception.Create('DeviceCapabilities reports different number of papers and paper-names');
  end;
  if numPaperNames > 0 then
  begin
    GetMem(pPaperNames, numPaperNames * Sizeof(TPapername));
    GetMem(pPapers, numPapers * Sizeof(Word));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_PAPERNAMES, Pchar(pPaperNames),
        nil);
      WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, Pchar(pPapers), nil);
      sl.clear;
      for i := 1 to numPaperNames do
      begin
        temp := pPapers^[i];
        sl.addObject(pPaperNames^[i], TObject(temp));
      end;
    finally
      FreeMem(pPaperNames);
      if pPapers <> nil then
        FreeMem(pPapers);
    end;
  end;
end;
 
procedure GetPapersizes(var sizes: TPaperSizes; index: Integer);
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  numPapers: Integer;
begin
  Printer.PrinterIndex := index;
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numPapers := WinSpool.DeviceCapabilities(Device, Port, DC_PAPERS, nil, nil);
  SetLength(sizes, numPapers);
  if numPapers > 0 then
    WinSpool.DeviceCapabilities(Device, Port, DC_PAPERSIZE, PChar(@sizes[0]), nil);
end;
 
procedure GetPaperInfo(var infos: TPaperInfos; index: Integer);
var
  sizes: TPaperSizes;
  sl: TStringlist;
  i: Integer;
begin
  sl := Tstringlist.Create;
  try
    GetPaperNames(sl, index);
    GetPaperSizes(sizes, index);
    Assert(sl.count = Length(sizes));
    SetLength(infos, sl.count);
    for i := 0 to sl.count - 1 do
    begin
      StrPLCopy(infos[i].papername, sl[i], Sizeof(TPapername) - 1);
      infos[i].paperID := LoWord(Longword(sl.Objects[i]));
      infos[i].papersize := sizes[i];
    end;
  finally
    sl.Free;
  end;
end;

procedure TForm1.btnDruckerEinstellenClick(Sender: TObject);
var
  i, PaperID: integer;
  Papers: TPaperInfos;
begin
  if PrinterSetupDialog.Execute then
  begin
    PaperID := GetPaperID;
    GetPaperInfo(Papers, Printer.PrinterIndex);
    for i := Low(Papers) to High(Papers) do
    begin
      if PaperID = Papers[i].paperID then
      begin
        label1.Caption := Papers[i].papername;
        BREAK;
      end;
    end;
  end;
end;