unit PrintObj;
{unit to programmatically set printer options so that user does not}
{have to go to the Printer Options Dialog Box}
{Revision 1.15}
interface
uses
Classes, Forms, Printers, SysUtils, Print, WinProcs, WinTypes, Messages;
{see the WinTypes unit for constant declarations such as}
{dmPaper_Letter, dmbin_Upper, etc}
const
CCHBinName = 24; {Size of bin name (should have been in PRINT.PAS}
CBinMax = 256; {Maximum number of bin sources}
CPaperNames = 256; {Maximum number of paper sizes}
type
TPrintSet = class (TObject)
private
{ Private declarations }
FDevice: PChar;
FDriver: PChar;
FPort: PChar;
FHandle: THandle;
FDeviceMode: PDevMode;
protected
{ Protected declarations }
procedure SetOrientation (Orientation: integer);
function GetOrientation: integer;
{-sets/gets the paper orientation}
procedure SetPaperSize (Size: integer);
function GetPaperSize: integer;
{-sets/gets the paper size}
procedure SetPaperLength (Length: integer);
function GetPaperLength: integer;
{-sets/gets the paper length}
procedure SetPaperWidth (Width: integer);
function GetPaperWidth: integer;
{-sets/gets the paper width}
procedure SetScale (Scale: integer);
function GetScale: integer;
{-sets/gets the printer scale (whatever that is)}
procedure SetCopies (Copies: integer);
function GetCopies: integer;
{-sets/gets the number of copies}
procedure SetBin (Bin: integer);
function GetBin: integer;
{-sets/gets the paper bin}
procedure SetPrintQuality (Quality: integer);
function GetPrintQuality: integer;
{-sets/gets the print quality}
procedure SetColor (Color: integer);
function GetColor: integer;
{-sets/gets the color (monochrome or color)}
procedure SetDuplex (Duplex: integer);
function GetDuplex: integer;
{-sets/gets the duplex setting}
procedure SetYResolution (YRes: integer);
function GetYResolution: integer;
{-sets/gets the y-resolution of the printer}
procedure SetTTOption (Option: integer);
function GetTTOption: integer;
{-sets/gets the TrueType option}
public
{ Public declarations }
constructor Create;
{-inititalizes class}
destructor Destroy; override;
{-destroys class}
function GetBinSourceList: TStringList;
{-returns the current list of bins}
function GetPaperList: TStringList;
{-returns the current list of paper sizes}
procedure SetDeviceMode;
{-updates the printers TDevMode structure}
procedure SaveToDefaults;
{-updates the default settings for the current printer}
{ Property declarations }
property Orientation: integer read GetOrientation
write SetOrientation;
property PaperSize: integer read GetPaperSize
write SetPaperSize;
property PaperLength: integer read GetPaperLength
write SetPaperLength;
property PaperWidth: integer read GetPaperWidth
write SetPaperWidth;
property Scale: integer read GetScale
write SetScale;
property Copies: integer read GetCopies
write SetCopies;
property Bin: integer read GetBin
write SetBin;
property PrintQuality: integer read GetPrintQuality
write SetPrintQuality;
property Color: integer read GetColor
write SetColor;
property Duplex: integer read GetDuplex
write SetDuplex;
property YResolution: integer read GetYResolution
write SetYResolution;
property TTOption: integer read GetTTOption
write SetTTOption;
end; { TPrintSet }
var
PrintSet: TPrintSet;
implementation
constructor TPrintSet.Create;
{-inititalizes class}
begin
GetMem (FDevice, 255);
GetMem (FDriver, 255);
GetMem (FPort, 255);
Printer.GetPrinter (FDevice, FDriver, FPort, FHandle);
if FHandle = 0 then
begin {driver not loaded}
Printer.PrinterIndex := Printer.PrinterIndex;
{-forces Printer object to load driver}
end; { if... }
Printer.GetPrinter (FDevice, FDriver, FPort, FHandle);
if FHandle<>0 then
begin
FDeviceMode := Ptr (FHandle, 0);
{-PDeviceMode now points to Printer.DeviceMode}
FDeviceMode^.dmFields := 0;
end {:} else
begin
FDeviceMode := nil;
Raise EPrinter.Create ('Error retrieving DeviceMode');
end; { if... }
end; { TPrintSet.Create }
function TPrintSet.GetBinSourceList: TStringList;
{-returns the current list of bins (returns nil for none)}
type
TcchBinName = array[0..CCHBinName-1] of Char;
TBinArray = array[1..cBinMax] of TcchBinName;
PBinArray = ^TBinArray;
var
NumBinsReq: Longint; {number of bins required}
NumBinsRec: Longint; {number of bins received}
BinArray: PBinArray;
BinList: TStringList;
BinStr: String;
i: Longint;
DevCaps: TFarProc;
DrvHandle: THandle;
DriverName: String;
begin
Result := nil;
BinArray := nil;
try
DrvHandle := LoadLibrary (FDriver);
if DrvHandle <> 0 then
begin
DevCaps := GetProcAddress (DrvHandle, 'DeviceCapabilities');
if DevCaps<>nil then
begin
NumBinsReq := TDeviceCapabilities (DevCaps)(FDevice, FPort, DC_BinNames,
nil, FDeviceMode^);
GetMem (BinArray, NumBinsReq * SizeOf (TcchBinName));
NumBinsRec := TDeviceCapabilities (DevCaps)(FDevice, FPort, DC_BinNames,
PChar (BinArray), FDeviceMode^);
if NumBinsRec <> NumBinsReq then
begin
{raise an exception}
Raise EPrinter.Create ('Error retrieving Bin Source Info');
end; { if... }
{now convert to TStringList}
BinList := TStringList.Create;
for i := 1 to NumBinsRec do
begin
BinStr := StrPas (BinArray^[i]);
BinList.Add (BinStr);
end; { next i }
end; { if... }
FreeLibrary (DrvHandle);
Result := BinList;
end {:} else
begin
{raise an exception}
DriverName := StrPas (FDriver);
Raise EPrinter.Create ('Error loading driver '+DriverName);
end; { else }
finally
if BinArray <> nil then
FreeMem (BinArray, NumBinsReq * SizeOf (TcchBinName));
end; { try }
end; { TPrintSet.GetBinSourceList }
function TPrintSet.GetPaperList: TStringList;
{-returns the current list of paper sizes (returns nil for none)}
type
TcchPaperName = array[0..CCHPaperName-1] of Char;
TPaperArray = array[1..cPaperNames] of TcchPaperName;
PPaperArray = ^TPaperArray;
var
NumPaperReq: Longint; {number of paper types required}
NumPaperRec: Longint; {number of paper types received}
PaperArray: PPaperArray;
PaperList: TStringList;
PaperStr: String;
i: Longint;
DevCaps: TFarProc;
DrvHandle: THandle;
DriverName: String;
begin
Result := nil;
PaperArray := nil;
try
DrvHandle := LoadLibrary (FDriver);
if DrvHandle <> 0 then
begin
DevCaps := GetProcAddress (DrvHandle, 'DeviceCapabilities');
if DevCaps<>nil then
begin
NumPaperReq := TDeviceCapabilities (DevCaps)(FDevice, FPort, DC_PaperNames,
nil, FDeviceMode^);
GetMem (PaperArray, NumPaperReq * SizeOf (TcchPaperName));
NumPaperRec := TDeviceCapabilities (DevCaps)(FDevice, FPort, DC_PaperNames,
PChar (PaperArray), FDeviceMode^);
if NumPaperRec <> NumPaperReq then
begin
{raise an exception}
Raise EPrinter.Create ('Error retrieving Paper Info');
end; { if... }
{now convert to TStringList}
PaperList := TStringList.Create;
for i := 1 to NumPaperRec do
begin
PaperStr := StrPas (PaperArray^[i]);
PaperList.Add (PaperStr);
end; { next i }
end; { if... }
FreeLibrary (DrvHandle);
Result := PaperList;
end {:} else
begin
{raise an exception}
DriverName := StrPas (FDriver);
Raise EPrinter.Create ('Error loading driver '+DriverName);
end; { else }
finally
if PaperArray <> nil then
FreeMem (PaperArray, NumPaperReq * SizeOf (TcchPaperName));
end; { try }
end; { TPrintSet.GetPaperList }
procedure TPrintSet.SetDeviceMode;
{-updates the drived TDevMode structure}
var
DrvHandle: THandle;
ExtDevCaps: TFarProc;
DriverName: String;
ExtDevCode: Integer;
OutDevMode: PDevMode;
begin
DrvHandle := LoadLibrary (FDriver);
if DrvHandle <> 0 then
begin
ExtDevCaps := GetProcAddress (DrvHandle, 'ExtDeviceMode');
if ExtDevCaps<>nil then
begin
ExtDevCode := TExtDeviceMode (ExtDevCaps)
(0, DrvHandle, FDeviceMode^, FDevice, FPort,
FDeviceMode^, nil, DM_IN_BUFFER or DM_OUT_BUFFER);
if ExtDevCode <> IDOK then
begin
{raise an exception}
raise EPrinter.Create ('Error updating printer driver.');
end; { if... }
end; { if... }
FreeLibrary (DrvHandle);
end {:} else
begin
{raise an exception}
DriverName := StrPas (FDriver);
Raise EPrinter.Create ('Error loading driver '+DriverName);
end; { else }
end; { TPrintSet.SetDeviceMode }
procedure TPrintSet.SaveToDefaults;
{-updates the default settings for the current printer}
var
DrvHandle: THandle;
ExtDevCaps: TFarProc;
DriverName: String;
ExtDevCode: Integer;
OutDevMode: PDevMode;
begin
DrvHandle := LoadLibrary (FDriver);
if DrvHandle <> 0 then
begin
ExtDevCaps := GetProcAddress (DrvHandle, 'ExtDeviceMode');
if ExtDevCaps<>nil then
begin
ExtDevCode := TExtDeviceMode (ExtDevCaps)
(0, DrvHandle, FDeviceMode^, FDevice, FPort,
FDeviceMode^, nil, DM_IN_BUFFER OR DM_UPDATE);
if ExtDevCode <> IDOK then
begin
{raise an exception}
raise EPrinter.Create ('Error updating printer driver.');
end {:} else
SendMessage ($FFFF, WM_WININICHANGE, 0, 0);
end; { if... }
FreeLibrary (DrvHandle);
end {:} else
begin
{raise an exception}
DriverName := StrPas (FDriver);
Raise EPrinter.Create ('Error loading driver '+DriverName);
end; { else }
end; { TPrintSet.SaveToDefaults }
procedure TPrintSet.SetOrientation (Orientation: integer);
{-sets the paper orientation}
begin
FDeviceMode^.dmOrientation := Orientation;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_ORIENTATION;
end; { TPrintSet.SetOrientation }
function TPrintSet.GetOrientation: integer;
{-gets the paper orientation}
begin
Result := FDeviceMode^.dmOrientation;
end; { TPrintSet.GetOrientation }
procedure TPrintSet.SetPaperSize (Size: integer);
{-sets the paper size}
begin
FDeviceMode^.dmPaperSize := Size;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERSIZE;
end; { TPrintSet.SetPaperSize }
function TPrintSet.GetPaperSize: integer;
{-gets the paper size}
begin
Result := FDeviceMode^.dmPaperSize;
end; { TPrintSet.GetPaperSize }
procedure TPrintSet.SetPaperLength (Length: integer);
{-sets the paper length}
begin
FDeviceMode^.dmPaperLength := Length;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERLENGTH;
end; { TPrintSet.SetPaperLength }
function TPrintSet.GetPaperLength: integer;
{-gets the paper length}
begin
Result := FDeviceMode^.dmPaperLength;
end; { TPrintSet.GetPaperLength }
procedure TPrintSet.SetPaperWidth (Width: integer);
{-sets the paper width}
begin
FDeviceMode^.dmPaperWidth := Width;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERWIDTH;
end; { TPrintSet.SetPaperWidth }
function TPrintSet.GetPaperWidth: integer;
{-gets the paper width}
begin
Result := FDeviceMode^.dmPaperWidth;
end; { TPrintSet.GetPaperWidth }
procedure TPrintSet.SetScale (Scale: integer);
{-sets the printer scale (whatever that is)}
begin
FDeviceMode^.dmScale := Scale;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_SCALE;
end; { TPrintSet.SetScale }
function TPrintSet.GetScale: integer;
{-gets the printer scale}
begin
Result := FDeviceMode^.dmScale;
end; { TPrintSet.GetScale }
procedure TPrintSet.SetCopies (Copies: integer);
{-sets the number of copies}
begin
FDeviceMode^.dmCopies := Copies;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_COPIES;
end; { TPrintSet.SetCopies }
function TPrintSet.GetCopies: integer;
{-gets the number of copies}
begin
Result := FDeviceMode^.dmCopies;
end; { TPrintSet.GetCopies }
procedure TPrintSet.SetBin (Bin: integer);
{-sets the paper bin}
begin
FDeviceMode^.dmDefaultSource := Bin;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_DEFAULTSOURCE;
end; { TPrintSet.SetBin }
function TPrintSet.GetBin: integer;
{-gets the paper bin}
begin
Result := FDeviceMode^.dmDefaultSource;
end; { TPrintSet.GetBin }
procedure TPrintSet.SetPrintQuality (Quality: integer);
{-sets the print quality}
begin
FDeviceMode^.dmPrintQuality := Quality;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PRINTQUALITY;
end; { TPrintSet.SetPrintQuality }
function TPrintSet.GetPrintQuality: integer;
{-gets the print quality}
begin
Result := FDeviceMode^.dmPrintQuality;
end; { TPrintSet.GetPrintQuality }
procedure TPrintSet.SetColor (Color: integer);
{-sets the color (monochrome or color)}
begin
FDeviceMode^.dmColor := Color;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_ORIENTATION;
end; { TPrintSet.SetColor }
function TPrintSet.GetColor: integer;
{-gets the color}
begin
Result := FDeviceMode^.dmColor;
end; { TPrintSet.GetColor }
procedure TPrintSet.SetDuplex (Duplex: integer);
{-sets the duplex setting}
begin
FDeviceMode^.dmDuplex := Duplex;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_DUPLEX;
end; { TPrintSet.SetDuplex }
function TPrintSet.GetDuplex: integer;
{-gets the duplex setting}
begin
Result := FDeviceMode^.dmDuplex;
end; { TPrintSet.GetDuplex }
procedure TPrintSet.SetYResolution (YRes: integer);
{-sets the y-resolution of the printer}
var
PrintDevMode: Print.PDevMode;
begin
PrintDevMode := @FDeviceMode^;
PrintDevMode^.dmYResolution := YRes;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_YRESOLUTION;
end; { TPrintSet.SetYResolution }
function TPrintSet.GetYResolution: integer;
{-gets the y-resolution of the printer}
var
PrintDevMode: Print.PDevMode;
begin
PrintDevMode := @FDeviceMode^;
Result := PrintDevMode^.dmYResolution;
end; { TPrintSet.GetYResolution }
procedure TPrintSet.SetTTOption (Option: integer);
{-sets the TrueType option}
var
PrintDevMode: Print.PDevMode;
begin
PrintDevMode := @FDeviceMode^;
PrintDevMode^.dmTTOption := Option;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_TTOPTION;
end; { TPrintSet.SetTTOption }
function TPrintSet.GetTTOption: integer;
{-gets the TrueType option}
var
PrintDevMode: Print.PDevMode;
begin
PrintDevMode := @FDeviceMode^;
Result := PrintDevMode^.dmTTOption;
end; { TPrintSet.GetTTOption }
destructor TPrintSet.Destroy;
{-destroys class}
begin
FreeMem (FDevice, 255);
FreeMem (FDriver, 255);
FreeMem (FPort, 255);
end; { TPrintSet.Destroy }
end. { PrintObj }
