How to get the names, ID's and sizes for paper formats and bins supported by a printer

Problem/Question/Abstract:

I'm trying to get a list of paper sizes for a given printer. The same list that's in the drop downs in the printer setup dialogs. It appears to be printer dependent. I tried EnumForms (in Win2000) but that gave a very large list (139 items). The printer setup dlg only lists about a dozen for each printer. This list seems to be the same list via Control Panel | Printers | Server Properties | Forms. Also, the names are slightly different in the printer setup dialog. instead of "Letter" the dialog has "Letter 81/2 x 11 in" (for some of my printers). I also tried DeviceCapabilities with the DC_PAPERNAMES flag, but that only returned the current paper size, though with the more user-friendly dialog paper size name ("Letter 81/2 x 11 in"). Frankly I expected DeviceCapabilities to be the solution. EnumForms is a WinNT call. I assume there's another API for Win9x.

Answer:

Pick what you need from the unit below:


{
PrintUtils:
This unit collects a number of printer-related helper routines.
Author: Dr. Peter Below
Version 1.0 created 26.11.2001
Current revision: 1.01
Last modified: 03.12.2001
}

{$BOOLEVAL OFF} {Unit depends on shortcut boolean evaluation}
unit PrintUtils;

interface

uses
  Windows, Classes, DblRect;

type
  TPaperName = array[0..63] of Char;
  TPaperInfo = packed record
    papername: TPapername; { display name of the paper }
    paperID: Word; { DMPAPER_* ID }
    papersize: TPoint; { Size in 0.1 mm }
  end;
  TPaperInfos = array of TPaperInfo;
  TPaperSizes = array of TPoint;
  TPageInfo = record
    width, height: Integer; { physical width and height, in dots }
    offsetX, offsetY: Integer; { nonprintable margin, in dots }
    resX, resY: Integer; { logical resolution, dots per inch }
  end;

  {Return the names, IDs, and sizes for all paper formats supported by a printer. Index is the index of the printer in the Printers array, or -1 if the default printer should be examined.}
procedure GetPaperInfo(var infos: TPaperInfos; index: Integer = -1);
{Return the names and IDs for all bins supported by a printer. The IDs are returned in the
strings Objects property. Index is the index of the printer in the Printers array, or -1 if the default printer should be examined.}
procedure GetBinnames(sl: TStrings; index: Integer = -1);
{Return the names and IDs for all paper formats supported by a printer. The IDs are returned in the strings Objects property. Index is the index of the printer in the Printers array, or -1 if the default printer should be examined.}
procedure GetPapernames(sl: TStrings; index: Integer = -1);
{Return page information for the selected printer.}
procedure GetPageinfo(var info: TPageInfo; index: Integer = -1);
{Convert a page-relative position in mm to a printer canvas position in dots. The page coordinate system is oriented the same as the MM_TEXT canvas coordinate system, origin at top left of  page, positive Y axis downwards.}
function PointMMtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
{Convert a printer canvas position in dots to a page-relative position in mm. The page coordinate system is oriented the same as the MM_TEXT canvas coordinate system, origin at top left of page, positive Y axis downwards.}
function PointDotsToMM(const pt: TPoint; const info: TPageInfo): TDoublePoint;
{Convert a page-relative position in inch to a printer canvas position in dots. The page coordinate system is oriented the same as the MM_TEXT canvas coordinate system, origin at top left of page, positive Y axis downwards.}
function PointInchtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
{Convert a printer canvas position in dots to a page-relative position in inch. The page coordinate system is oriented the same as the MM_TEXT canvas coordinate system, origin at top left of page, positive Y axis downwards.}
function PointDotsToInch(const pt: TPoint; const info: TPageInfo): TDoublePoint;
{Convert inches to mm}
function InchToMM(const value: Double): Double;
{Convert mm to inches}
function MMToInch(const value: Double): Double;
{Select a printer bin. The parameter is the DMBIN_* index to use. The current printer is always used.}
procedure SelectPrinterBin(binID: SmallInt);
{Select a standard paper size. The parameter is the DMPAPER_* index to use. The current printer
is always used.}
procedure SelectPaper(paperID: SmallInt);
{Reload a printers DEVMODE record.}
procedure ResetPrinter;

implementation

uses
  WinSpool, Sysutils, Printers;

procedure GetBinnames(sl: TStrings; index: Integer);
type
  TBinName = array[0..23] of Char;
  TBinNameArray = array[1..High(Integer) div Sizeof(TBinName)] of TBinName;
  PBinnameArray = ^TBinNameArray;
  TBinArray = array[1..High(Integer) div Sizeof(Word)] of Word;
  PBinArray = ^TBinArray;
var
  Device, Driver, Port: array[0..255] of Char;
  hDevMode: THandle;
  i, numBinNames, numBins, temp: Integer;
  pBinNames: PBinnameArray;
  pBins: PBinArray;
begin
  Assert(Assigned(sl));
  Printer.PrinterIndex := index;
  Printer.GetPrinter(Device, Driver, Port, hDevmode);
  numBinNames := WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, nil, nil);
  numBins := WinSpool.DeviceCapabilities(Device, Port, DC_BINS, nil, nil);
  if numBins <> numBinNames then
  begin
    raise Exception.Create('DeviceCapabilities reports different number of bins and ' +  'bin names!');
  end;
  if numBinNames > 0 then
  begin
    GetMem(pBinNames, numBinNames * Sizeof(TBinname));
    GetMem(pBins, numBins * Sizeof(Word));
    try
      WinSpool.DeviceCapabilities(Device, Port, DC_BINNAMES, Pchar(pBinNames), nil);
      WinSpool.DeviceCapabilities(Device, Port, DC_BINS, Pchar(pBins), nil);
      sl.clear;
      for i := 1 to numBinNames do
      begin
        temp := pBins^[i];
        sl.addObject(pBinNames^[i], TObject(temp));
      end;
    finally
      FreeMem(pBinNames);
      if pBins <> nil then
        FreeMem(pBins);
    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 GetPageinfo(var info: TPageInfo; index: Integer = -1);
begin
  if index > -1 then
    Printer.PrinterIndex := index;
  with Printer do
  begin
    info.resX := GetDeviceCaps(handle, LOGPIXELSX);
    info.resY := GetDeviceCaps(handle, LOGPIXELSY);
    info.offsetX := GetDeviceCaps(handle, PHYSICALOFFSETX);
    info.offsetY := GetDeviceCaps(handle, PHYSICALOFFSETY);
    info.width := GetDeviceCaps(handle, PHYSICALWIDTH);
    info.height := GetDeviceCaps(handle, PHYSICALHEIGHT);
  end;
end;

function PointMMtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
var
  dp: TDoublePoint;
begin
  dp.X := MMToInch(pt.X);
  dp.Y := MMToInch(pt.Y);
  Result := PointInchtoDots(dp, info);
end;

function PointDotsToMM(const pt: TPoint; const info: TPageInfo): TDoublePoint;
begin
  Result := PointDotsToInch(pt, info);
  Result.X := InchToMM(Result.X);
  Result.Y := InchToMM(Result.Y);
end;

function PointInchtoDots(const pt: TDoublePoint; const info: TPageInfo): TPoint;
begin
  Result.X := Round(pt.X * info.resX) - info.offsetX;
  Result.Y := Round(pt.Y * info.resY) - info.offsetY;
end;

function PointDotsToInch(const pt: TPoint; const info: TPageInfo): TDoublePoint;
begin
  Result.X := (pt.X + info.offsetX) / info.resX;
  Result.Y := (pt.Y + info.offsetY) / info.resY;
end;

const
  mmPerInch = 25.4;

function InchToMM(const value: Double): Double;
begin
  Result := value * mmPerInch;
end;

function MMToInch(const value: Double): Double;
begin
  Result := value / mmPerInch;
end;

procedure SelectPrinterBin(binID: 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_DEFAULTSOURCE;
        dmDefaultSource := binID;
      end;
    finally
      GlobalUnlock(hDevicemode);
    end;
  end;
end;

procedure SelectPaper(paperID: 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;
        dmPapersize := paperID;
      end;
    finally
      GlobalUnlock(hDevicemode);
    end;
  end;
end;

procedure ResetPrinter;
var
  Device, Driver, Port: array[0..80] of Char;
  DevMode: THandle;
begin
  Printer.GetPrinter(Device, Driver, Port, DevMode);
  Printer.SetPrinter(Device, Driver, Port, 0)
end;

end.

{
DblRect:
This unit defines point and rect types which store their boundaries as doubles, plus some routines
to work with these types.
Author: Dr. Peter Below
Version 1.0 created 22.02.1997
Version 1.01 created 04.12.2001, added InflateDoubleRect and modified comments for Time2Help.
Current revision: 1.01
Last modified: 4 Dezember 2001
}

{$BOOLEVAL OFF} {Unit depends on shortcut boolean evaluation}
unit DblRect;

interface

uses
  WinTypes;

type
  TDoublePoint = record
    X, Y: Double;
  end;
  TDoubleRect = record
    case Byte of
      0: (Left, Top, Right, Bottom: Double);
      1: (topleft, bottomright: TDoublePoint);
      2: (X1, Y1, X2, Y2: Double);
  end;

const
  EmptyDoubleRect: TDoubleRect = (Left: 0.0; Top: 0.0; Right: 0.0; Bottom: 0.0);
  EmptyPoint: TDoublePoint = (X: 0.0; Y: 0.0);

{$IFDEF WIN32}
var
{$ENDIF}
  DefaultEpsilon: Double = 1.0 e - 8;

function DoublePoint(const aX, aY: Double): TDoublePoint;
function AreDoublePointsEqual(const P1, P2: TDoublePoint): Boolean;
procedure OffsetDoublePoint(var P: TDoublePoint; dx, dy: Double);
procedure ScaleDoublePoint(var P: TDoublePoint; factor: DOuble);
function DoublePointDistance(const P1, P2: TDoublePoint): Double;
function PointFromDoublePoint(const P: TDoublePoint): TPoint;
function DoublePointFromPoint(const P: TPoint): TDoublePoint;
function DoubleRect(const L, T, R, B: Double): TDoubleRect;
procedure VerifyDoubleRect(var R: TDoubleRect);
function AreDoubleRectsEqual(const R1, R2: TDoubleRect): Boolean;
procedure OffsetDoubleRect(var R: TDoubleRect; dx, dy: Double);
procedure ScaleDoubleRect(var R: TDoubleRect; cx, cy: Double);
procedure InflateDoubleRect(var R: TDoubleRect; dx, dy: Double);
procedure IntersectDoubleRect(const R1, R2: TDoubleRect; var isect: TDoubleRect);
function IsDoubleRectEmpty(const R: TDoubleRect): Boolean;
function RectFromDoubleRect(const R: TDoubleRect): TRect;
function DoubleRectFromRect(const R: TRect): TDoubleRect;
function DoublePointInRect(const P: TDOublePoint; const R: TDoubleRect): Boolean;
function ULeft(const R: TDoubleRect): TDoublePoint;
function URight(const R: TDoubleRect): TDoublePoint;
function LLeft(const R: TDoubleRect): TDoublePoint;
function LRight(const R: TDoubleRect): TDoublePoint;

implementation

{Returns a TDoublePoint constructed from the passed coordinates.}

function DoublePoint(const aX, aY: Double): TDoublePoint;
begin
  with Result do
  begin
    X := aX;
    Y := aY;
  end;
end;

{Compares the two passed points and returns true if they are considered equal, false otherwise.
The points are equal if their coordinates differ less than the DefaultEpsilon.}

function AreDoublePointsEqual(const P1, P2: TDoublePoint): Boolean;
begin
  Result := (Abs(P1.X - P2.X) < DefaultEpsilon) and (Abs(P1.Y - P2.Y) <
    DefaultEpsilon);
end;

{: Moves the passed point by the passed increments.}

procedure OffsetDoublePoint(var P: TDoublePoint; dx, dy: Double);
begin
  with P do
  begin
    X := X + dx;
    Y := Y + dy;
  end;
end;

{Multiplies the passed points coordinates by factor.}

procedure ScaleDoublePoint(var P: TDoublePoint; factor: DOuble);
begin
  with P do
  begin
    X := X * factor;
    Y := Y * factor;
  end;
end;

{Returns the distance between the passed points. This will always be a positive number.}

function DoublePointDistance(const P1, P2: TDoublePoint): Double;
begin
  Result := Sqrt(Sqr(P1.X - P2.X) + Sqr(P1.Y - P2.Y));
end;

{Converts the passed TDoublePoint to a TPoint and returns the result.}

function PointFromDoublePoint(const P: TDoublePoint): TPoint;
begin
  with Result do
  begin
    X := Round(P.X);
    Y := Round(P.Y);
  end;
end;

{Converts the passed TPoint to a TDoublePoint and returns the result.}

function DoublePointFromPoint(const P: TPoint): TDoublePoint;
begin
  with Result do
  begin
    X := P.X;
    Y := P.Y;
  end;
end;

{Returns a TDoubleRect made from the passed parameters. Makes certain that the resulting rect meets the criteria Left < Right and Top < Bottom, boundaries may be swapped to achieve this.}

function DoubleRect(const L, T, R, B: Double): TDoubleRect;
begin
  with Result do
  begin
    if L <= R then
    begin
      Left := L;
      Right := R;
    end
    else
    begin
      Left := R;
      Right := L;
    end;
    if T <= B then
    begin
      Top := T;
      Bottom := B;
    end
    else
    begin
      Top := B;
      Bottom := T;
    end;
  end;
end;

{Makes sure the passed rectangle meets the constraints Left < Right and Top < Bottom.
If needed, boundaries will be swapped.}

procedure VerifyDoubleRect(var R: TDoubleRect);
var
  temp: Double;
begin
  with R do
  begin
    if Left > Right then
    begin
      temp := Left;
      Left := right;
      Right := temp;
    end;
    if Top > Bottom then
    begin
      temp := Top;
      Top := Bottom;
      Bottom := temp;
    end;
  end;
end;

{Returns True if the two passed rects R1 and R2 are equal, false otherwise. Equal in this case means that each of the four coordinates of P1 has a difference of less than DefaultEpsilon from the corresponding coordinate of P2.}

function AreDoubleRectsEqual(const R1, R2: TDoubleRect): Boolean;
begin
  Result := (Abs(R1.X1 - R2.X1) < DefaultEpsilon) and (Abs(R1.Y1 - R2.Y1) <
    DefaultEpsilon) and
    (Abs(R1.X2 - R2.X2) < DefaultEpsilon) and (Abs(R1.Y2 - R2.Y2) < DefaultEpsilon);
end;

{Moves the passed rectangle by the given increments.}

procedure OffsetDoubleRect(var R: TDoubleRect; dx, dy: Double);
begin
  with R do
  begin
    X1 := X1 + dx;
    Y1 := Y1 + dy;
    X2 := X2 + dx;
    Y2 := Y2 + dy;
  end;
end;

{Scales the passed rectangle by the factors given. This changes only the size of the rectangle, the upper left corner coordinates stay fixed.}

procedure ScaleDoubleRect(var R: TDoubleRect; cx, cy: Double);
begin
  with R do
  begin
    X2 := (X2 - X1) * cx + X1;
    Y2 := (Y2 - Y1) * cy + Y1;
  end;
end;

{
InflateDoubleRect:
Change the size of a double rect.
Param R is the rect to change
Param dx is the horizontal size increment to apply
Param dy is the vertical size increment to apply
Like the API function InflateRect this procedure will subtract dx from the r.left, add dx to r.right, subtract dy
from r.top and add dy to r.bottom. So the rectangle width and height changes by 2 times the increment.
Created 04.12.2001 by P. Below
}

procedure InflateDoubleRect(var R: TDoubleRect; dx, dy: Double);
begin
  r.Left := r.Left - dx;
  r.Right := r.Right + dx;
  r.Top := r.Top - dy;
  r.Bottom := r.Bottom + dy;
end;

{Calculates the intersection of the two rectangles passed and returns the result in isect. The result will be empty if the rectangles are disjunct. Note that this procedure assumes that the rectangles obey the constraints Left <= Right and Top <= Bottom !}

procedure IntersectDoubleRect(const R1, R2: TDoubleRect; var isect: TDoubleRect);
begin
  if (R1.Left > R2.Right) or (R1.Right < R2.Left) or (R1.Top > R2.Bottom) or (R1.Bottom
    < R2.Top) then
  begin
    {The two rectangles do not intersect}
    isect := EmptyDoubleRect;
  end
  else
  begin
    {Figure out placement of left border of result rectangle, which is the rightmost of the two left borders of the source rectangles.}
    if R1.Left < R2.Left then
      isect.Left := R2.Left
    else
      isect.Left := R1.Left;
    {Figure out placement of top border of result rectangle, which is the bottommost of the two top borders of the source rectangles.}
    if R1.Top < R2.Top then
      isect.Top := R2.Top
    else
      isect.Top := R1.Top;
    {Figure out placement of right border of result rectangle, which is the leftmost of the two Right borders of the source rectangles.}
    if R1.Right > R2.Right then
      isect.Right := R2.Right
    else
      isect.Right := R1.Right;
    {Figure out placement of Bottom border of result rectangle, which is the topmost of the two Bottom borders of the source rectangles.}
    if R1.Bottom > R2.Bottom then
      isect.Bottom := R2.Bottom
    else
      isect.Bottom := R1.Bottom;
  end;
end;

{Returns True if the passed rect spans no area, meaning the TopLeft and BottomRight corners are equal inside the precision given by the default threshold value DefaultEpsilon}

function IsDoubleRectEmpty(const R: TDoubleRect): Boolean;
begin
  Result := AreDoublePointsEqual(R.TopLeft, R.BottomRight);
end;

{Constructs a TRect from the passed TDoubleRect and returns it. The standard Round function is used to convert floating point to integer.}

function RectFromDoubleRect(const R: TDoubleRect): TRect;
begin
  with Result do
  begin
    Left := Round(R.Left);
    Top := Round(R.Top);
    Right := Round(R.Right);
    Bottom := Round(R.Bottom);
  end;
end;

{Constructs a TDoubleRect from the passed rect, validates it and returns it.}

function DoubleRectFromRect(const R: TRect): TDoubleRect;
begin
  with Result do
  begin
    Left := R.Left;
    Top := R.Top;
    Right := R.Right;
    Bottom := R.Bottom;
  end;
  VerifyDoubleRect(Result);
end;

{Performs a point-in-rectangle test and returns True, if the passed point is inside the rectangle or on one of its borders, false otherwise. The rectangle must meet the constraints  Left <= Right and Top <= Bottom !}

function DoublePointInRect(const P: TDOublePoint; const R: TDoubleRect): Boolean;
begin
  with R, P do
  begin
    Result := (X >= Left) and (X <= Right) and (Y >= Top) and (Y <= Bottom);
  end;
end;

{Returns the upper left corner of the passed rectangle}

function ULeft(const R: TDoubleRect): TDoublePoint;
begin
  Result := R.TopLeft;
end;

{Returns the upper right corner of the passed rectangle}

function URight(const R: TDoubleRect): TDoublePoint;
begin
  with R, Result do
  begin
    X := Right;
    Y := Top;
  end;
end;

{Returns the lower left corner of the passed rectangle}

function LLeft(const R: TDoubleRect): TDoublePoint;
begin
  with R, Result do
  begin
    X := Left;
    Y := Bottom;
  end;
end;

{Returns the lower right corner of the passed rectangle}

function LRight(const R: TDoubleRect): TDoublePoint;
begin
  Result := R.BottomRight;
end;

end.