EDSPRINT

Top  Previous  Next

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 }