[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]
unit EDSPrint;
{unit to programmatically set printer options so that user does not}
{have to go to the Printer Options Dialog Box}
{Revision 2.1}
interface
uses
Classes, Graphics, 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 (TComponent)
private
{ Private declarations }
FDevice: PChar;
FDriver: PChar;
FPort: PChar;
FHandle: THandle;
FDeviceMode: PDevMode;
FPrinter: integer; {same as Printer.PrinterIndex}
procedure CheckPrinter;
{-checks to see if the printer has changed and calls SetDeviceMode if it has}
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 (AOwner: TComponent); override;
{-initializes object}
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;
{-sets the internal pointer to the printers TDevMode structure}
procedure UpdateDeviceMode;
{-updates the printers TDevMode structure}
procedure SaveToDefaults;
{-updates the default settings for the current printer}
procedure SavePrinterAsDefault;
{-saves the current printer as the Window's default}
function GetPrinterName: string;
{-returns the name of the current printer}
function GetPrinterPort: string;
{-returns the port of the current printer}
function GetPrinterDriver: string;
{-returns the printer driver name of 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 DefaultSource: 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;
property PrinterName: String read GetPrinterName;
property PrinterPort: String read GetPrinterPort;
property PrinterDriver: String read GetPrinterDriver;
end; { TPrintSet }
procedure CanvasTextOutAngle (OutputCanvas: TCanvas; X,Y: integer;
Angle: Word; St: string);
{-prints text at the desired angle}
{-current font must be TrueType!}
procedure SetPixelsPerInch;
{-insures that PixelsPerInch is set so that text print at the desired size}
function GetResolution: TPoint;
{-returns the resolution of the printer}
procedure Register;
{-registers the printset component}
implementation
constructor TPrintSet.Create (AOwner: TComponent);
{-initializes object}
begin
inherited Create (AOwner);
if not (csDesigning in ComponentState) then
begin
GetMem (FDevice, 255);
GetMem (FDriver, 255);
GetMem (FPort, 255);
{SetDeviceMode;}
FPrinter := -99;
end {:} else
begin
FDevice := nil;
FDriver := nil;
FPort := nil;
end; { if... }
end; { TPrintSet.Create }
procedure TPrintSet.CheckPrinter;
{-checks to see if the printer has changed and calls SetDeviceMode if it has}
begin
if FPrinter <> Printer.PrinterIndex then
SetDeviceMode;
end; { TPrintSet.CheckPrinter }
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
CheckPrinter;
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
CheckPrinter;
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;
begin
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... }
FPrinter := Printer.PrinterIndex;
end; { TPrintSet.SetDeviceMode }
procedure TPrintSet.UpdateDeviceMode;
{-updates the loaded TDevMode structure}
var
DrvHandle: THandle;
ExtDevCaps: TFarProc;
DriverName: String;
ExtDevCode: Integer;
OutDevMode: PDevMode;
begin
CheckPrinter;
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.UpdateDeviceMode }
procedure TPrintSet.SaveToDefaults;
{-updates the default settings for the current printer}
var
DrvHandle: THandle;
ExtDevCaps: TFarProc;
DriverName: String;
ExtDevCode: Integer;
OutDevMode: PDevMode;
begin
CheckPrinter;
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.SavePrinterAsDefault;
{-saves the current printer as the Window's default}
var
DeviceStr: String;
begin
CheckPrinter; {make sure new printer is loaded}
{set the new device setting in the WIN.INI file}
DeviceStr := StrPas (FDevice) + ',' + StrPas (FDriver) + ',' + StrPas (FPort) + #0;
WriteProfileString ('windows', 'device', @DeviceStr[1]);
{force write to WIN.INI}
WriteProfileString (nil, nil, nil);
{broadcast to everyone that WIN.INI changed}
SendMessage ($FFFF, WM_WININICHANGE, 0, 0);
end; { TPrintSet.SavePrinterAsDefault }
procedure TPrintSet.SetOrientation (Orientation: integer);
{-sets the paper orientation}
begin
CheckPrinter;
FDeviceMode^.dmOrientation := Orientation;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_ORIENTATION;
end; { TPrintSet.SetOrientation }
function TPrintSet.GetOrientation: integer;
{-gets the paper orientation}
begin
CheckPrinter;
Result := FDeviceMode^.dmOrientation;
end; { TPrintSet.GetOrientation }
procedure TPrintSet.SetPaperSize (Size: integer);
{-sets the paper size}
begin
CheckPrinter;
FDeviceMode^.dmPaperSize := Size;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERSIZE;
end; { TPrintSet.SetPaperSize }
function TPrintSet.GetPaperSize: integer;
{-gets the paper size}
begin
CheckPrinter;
Result := FDeviceMode^.dmPaperSize;
end; { TPrintSet.GetPaperSize }
procedure TPrintSet.SetPaperLength (Length: integer);
{-sets the paper length}
begin
CheckPrinter;
FDeviceMode^.dmPaperLength := Length;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERLENGTH;
end; { TPrintSet.SetPaperLength }
function TPrintSet.GetPaperLength: integer;
{-gets the paper length}
begin
CheckPrinter;
Result := FDeviceMode^.dmPaperLength;
end; { TPrintSet.GetPaperLength }
procedure TPrintSet.SetPaperWidth (Width: integer);
{-sets the paper width}
begin
CheckPrinter;
FDeviceMode^.dmPaperWidth := Width;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PAPERWIDTH;
end; { TPrintSet.SetPaperWidth }
function TPrintSet.GetPaperWidth: integer;
{-gets the paper width}
begin
CheckPrinter;
Result := FDeviceMode^.dmPaperWidth;
end; { TPrintSet.GetPaperWidth }
procedure TPrintSet.SetScale (Scale: integer);
{-sets the printer scale (whatever that is)}
begin
CheckPrinter;
FDeviceMode^.dmScale := Scale;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_SCALE;
end; { TPrintSet.SetScale }
function TPrintSet.GetScale: integer;
{-gets the printer scale}
begin
CheckPrinter;
Result := FDeviceMode^.dmScale;
end; { TPrintSet.GetScale }
procedure TPrintSet.SetCopies (Copies: integer);
{-sets the number of copies}
begin
CheckPrinter;
FDeviceMode^.dmCopies := Copies;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_COPIES;
end; { TPrintSet.SetCopies }
function TPrintSet.GetCopies: integer;
{-gets the number of copies}
begin
CheckPrinter;
Result := FDeviceMode^.dmCopies;
end; { TPrintSet.GetCopies }
procedure TPrintSet.SetBin (Bin: integer);
{-sets the paper bin}
begin
CheckPrinter;
FDeviceMode^.dmDefaultSource := Bin;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_DEFAULTSOURCE;
end; { TPrintSet.SetBin }
function TPrintSet.GetBin: integer;
{-gets the paper bin}
begin
CheckPrinter;
Result := FDeviceMode^.dmDefaultSource;
end; { TPrintSet.GetBin }
procedure TPrintSet.SetPrintQuality (Quality: integer);
{-sets the print quality}
begin
CheckPrinter;
FDeviceMode^.dmPrintQuality := Quality;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_PRINTQUALITY;
end; { TPrintSet.SetPrintQuality }
function TPrintSet.GetPrintQuality: integer;
{-gets the print quality}
begin
CheckPrinter;
Result := FDeviceMode^.dmPrintQuality;
end; { TPrintSet.GetPrintQuality }
procedure TPrintSet.SetColor (Color: integer);
{-sets the color (monochrome or color)}
begin
CheckPrinter;
FDeviceMode^.dmColor := Color;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_ORIENTATION;
end; { TPrintSet.SetColor }
function TPrintSet.GetColor: integer;
{-gets the color}
begin
CheckPrinter;
Result := FDeviceMode^.dmColor;
end; { TPrintSet.GetColor }
procedure TPrintSet.SetDuplex (Duplex: integer);
{-sets the duplex setting}
begin
CheckPrinter;
FDeviceMode^.dmDuplex := Duplex;
FDeviceMode^.dmFields := FDeviceMode^.dmFields or DM_DUPLEX;
end; { TPrintSet.SetDuplex }
function TPrintSet.GetDuplex: integer;
{-gets the duplex setting}
begin
CheckPrinter;
Result := FDeviceMode^.dmDuplex;
end; { TPrintSet.GetDuplex }
procedure TPrintSet.SetYResolution (YRes: integer);
{-sets the y-resolution of the printer}
var
PrintDevMode: Print.PDevMode;
begin
CheckPrinter;
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
CheckPrinter;
PrintDevMode := @FDeviceMode^;
Result := PrintDevMode^.dmYResolution;
end; { TPrintSet.GetYResolution }
procedure TPrintSet.SetTTOption (Option: integer);
{-sets the TrueType option}
var
PrintDevMode: Print.PDevMode;
begin
CheckPrinter;
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
CheckPrinter;
PrintDevMode := @FDeviceMode^;
Result := PrintDevMode^.dmTTOption;
end; { TPrintSet.GetTTOption }
function TPrintSet.GetPrinterName: string;
{-returns the name of the current printer}
begin
CheckPrinter;
Result := StrPas (FDevice);
end; { TPrintSet.GetPrinterName }
function TPrintSet.GetPrinterPort: string;
{-returns the port of the current printer}
begin
CheckPrinter;
Result := StrPas (FPort);
end; { TPrintSet.GetPrinterPort }
function TPrintSet.GetPrinterDriver: string;
{-returns the printer driver name of the current printer}
begin
CheckPrinter;
Result := StrPas (FDriver);
end; { TPrintSet.GetPrinterDriver }
destructor TPrintSet.Destroy;
{-destroys class}
begin
if FDevice <> nil then
FreeMem (FDevice, 255);
if FDriver <> nil then
FreeMem (FDriver, 255);
if FPort <> nil then
FreeMem (FPort, 255);
inherited Destroy;
end; { TPrintSet.Destroy }
procedure CanvasTextOutAngle (OutputCanvas: TCanvas; X,Y: integer;
Angle: Word; St: string);
{-prints text at the desired angle}
{-current font must be TrueType!}
var
LogRec: TLogFont;
NewFontHandle: HFont;
OldFontHandle: HFont;
begin
GetObject (OutputCanvas.Font.Handle, SizeOf (LogRec), Addr (LogRec));
LogRec.lfEscapement := Angle;
NewFontHandle := CreateFontIndirect (LogRec);
OldFontHandle := SelectObject (OutputCanvas.Handle, NewFontHandle);
OutputCanvas.TextOut (x, y, St);
NewFontHandle := SelectObject (OutputCanvas.Handle, OldFontHandle);
DeleteObject (NewFontHandle);
end; { CanvasTextOutAngle }
procedure SetPixelsPerInch;
{-insures that PixelsPerInch is set so that text print at the desired size}
var
FontSize: integer;
begin
FontSize := Printer.Canvas.Font.Size;
Printer.Canvas.Font.PixelsPerInch := GetDeviceCaps (Printer.Handle, LOGPIXELSY );
Printer.Canvas.Font.Size := FontSize;
end; { SetPixelsPerInch }
function GetResolution: TPoint;
{-returns the resolution of the printer}
begin
Result.X := GetDeviceCaps(Printer.Handle, LogPixelsX);
Result.Y := GetDeviceCaps(Printer.Handle, LogPixelsY);
end; { GetResolution }
procedure Register;
{-registers the printset component}
begin
RegisterComponents('Domain', [TPrintSet]);
end; { Register }
end. { EDSPrint }
[Back to DELPHI SWAG index] [Back to Main SWAG index] [Original]