Set Printer Tray

[TopJack]

I posted this in the VBA forum thinking it was an appropriate place for the question - with the stunned silence that followed I guess maybe it was more of an API question. I'm trying to write this code in VBA but I guess it will be similar in VB. Here goes ........

I've been working on this for the last few days and I can't seem to get it working properly. Any advice would be appreciated.

I'm trying to get Excel(2003) to print (through XP platform) to a shared network printer but select the paper source (tray) at the same time. In Excel this seems particularly difficult - in Word its much easier. The printer is set up as default "auto" paper source but I want to use the manual paper feed instead for that print job only.

Below is my code so far (I can't take the credit because most came from the microsft support site). The code runs without error but just doesn't set the paper source. Any ideas on why, this has me stumped, my API knowledge is very limited ?

Option Explicit

Public Type PRINTER_DEFAULTS
pDatatype As Long
pDevmode As Long
DesiredAccess As Long
End Type

Public Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevmode As Long ' Pointer to DEVMODE
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long ' Pointer to SECURITY_DESCRIPTOR
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type

Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type

Public Const DM_DUPLEX = &H1000&
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
Public Const PRINTER_ACCESS_ADMINISTER = &H4
Public Const PRINTER_ACCESS_USE = &H8
Public Const STANDARD_RIGHTS_REQUIRED = &HF0000
Public Const PRINTER_ALL_ACCESS = (STANDARD_RIGHTS_REQUIRED Or _
PRINTER_ACCESS_ADMINISTER Or PRINTER_ACCESS_USE)

Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long

Public Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long

Public Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long

Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As Any) As Long
'pDefault As PRINTER_DEFAULTS) As Long

Public Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Byte, ByVal Command As Long) As Long

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(pDest As Any, pSource As Any, ByVal cbLength As Long)

Sub dummy_print()
Dim my_printer_address As String, my_printer_name As String, success As Boolean
            
my_printer_address = Application.Dialogs(xlDialogPrinterSetup).Show 'display printer list for selection

If (my_printer_address = False) Then Exit Sub   'terminate early cause user has cancelled

my_printer_name = Left(Application.ActivePrinter, InStr(Application.ActivePrinter, " on ") - 1)    'slice string for printer name (minus port name)

success = SetPrinterTray(my_printer_name, 4)

If Not success Then
    MsgBox "Error trying to change paper tray"
    Exit Sub
End If

Worksheets("Sheet1").Activate
Range("A1:D12").Select
Selection.PrintOut Copies:=1

End Sub

' ==================================================================
' SetPrinterTray
'
' Programmatically set the input source flag for the specified printer
' driver's default properties for paper input bin.
'
' Returns: True on success, False on error. (An error will also

' display a message box. This is done for informational value
' only. You should modify the code to support better error
' handling in your production application.)
'
' Parameters:
' sPrinterName - The name of the printer to be used.
'
' nBinSetting - One of the following standard settings:
' 1 = Upper
' 2 = Lower
' 3 = Middle
' 4 = Manual
' 5 = Envelope
' 6 = Envelope Manual
' 7 = Auto
' 8 = Tractor
' 9 = Small Format
' 10 = Large Format
' 11 = Large Capacity
'
' ==================================================================
Public Function SetPrinterTray(ByVal sPrinterName As String, _
ByVal nBinSetting As Long) As Boolean

Dim hPrinter As Long
Dim pd As PRINTER_DEFAULTS
Dim pinfo As PRINTER_INFO_2
Dim dm As DEVMODE

Dim yDevModeData() As Byte
Dim ypinfoMemory() As Byte
Dim nBytesNeeded As Long
Dim nRet As Long, nJunk As Long

On Error GoTo cleanup

If (nBinSetting < 1) Or (nBinSetting > 11) Then
    MsgBox "Error: Tray Setting is incorrect."
    Exit Function
End If

pd.DesiredAccess = PRINTER_ALL_ACCESS
nRet = OpenPrinter(sPrinterName, hPrinter, ByVal 0&) 'pd)
If (nRet = 0) Or (hPrinter = 0) Then
    If Err.LastDllError = 5 Then
        MsgBox "Access denied -- See article Q230743 for more info."
    Else
        MsgBox "Cannot open the printer specified " & _
        "(make sure the printer name is correct)."
    End If
    Exit Function
End If

nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
If (nRet < 0) Then
    MsgBox "Cannot get the size of the DEVMODE structure."
    GoTo cleanup
End If

ReDim yDevModeData(nRet + 100) As Byte
nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
If (nRet < 0) Then
    MsgBox "Cannot get the DEVMODE structure."
    GoTo cleanup
End If

Call CopyMemory(dm, yDevModeData(0), Len(dm))

If Not CBool(dm.dmFields & DM_DUPLEX) Then
    MsgBox "You cannot modify the duplex flag for this printer " & _
    "because it does not support duplex or the driver " & _
    "does not support setting it from the Windows API."
    GoTo cleanup
End If

dm.dmDefaultSource = nBinSetting
Call CopyMemory(yDevModeData(0), dm, Len(dm))

nRet = DocumentProperties(0, hPrinter, sPrinterName, _
VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), _
DM_IN_BUFFER Or DM_OUT_BUFFER)

If (nRet < 0) Then
    MsgBox "Unable to set tray setting to this printer."
    GoTo cleanup
End If

Call GetPrinter(hPrinter, 9, 0, 0, nBytesNeeded)
If (nBytesNeeded = 0) Then GoTo cleanup

ReDim ypinfoMemory(nBytesNeeded + 100) As Byte

nRet = GetPrinter(hPrinter, 9, ypinfoMemory(0), nBytesNeeded, nJunk)
If (nRet = 0) Then
    MsgBox "Unable to get shared printer settings."
    GoTo cleanup
End If

Call CopyMemory(pinfo, ypinfoMemory(0), Len(pinfo))
pinfo.pDevmode = VarPtr(yDevModeData(0))
pinfo.pSecurityDescriptor = 0
Call CopyMemory(ypinfoMemory(0), pinfo, Len(pinfo))

'Level 9 access is for current user profile (preferences). Level 2 access is for administration.
nRet = SetPrinter(hPrinter, 9, ypinfoMemory(0), 0)
If (nRet = 0) Then
    MsgBox "Unable to set shared printer settings."
End If

SetPrinterTray = CBool(nRet)

cleanup:
If (hPrinter <> 0) Then Call ClosePrinter(hPrinter)

End Function

 

[TopJack]

Found out what was wrong in the end. It was how I declared the SetPrinter function and also the timing of when I close the printer.

Thanks for the interest anyway.

Here is the main block of code that I used in the end - I know its VBA but its similar logic :-

Public Type PRINTER_INFO_9
pDevmode As Long ' Pointer to DEVMODE
End Type
 
Public Type DEVMODE
dmDeviceName As String * 32
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * 32
dmUnusedPadding As Integer
dmBitsPerPel As Integer
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
dmICMMethod As Long
dmICMIntent As Long
dmMediaType As Long
dmDitherType As Long
dmReserved1 As Long
dmReserved2 As Long
End Type
 
Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
"OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
pDefault As Any) As Long
 
Public Declare Function GetPrinter Lib "winspool.drv" Alias _
"GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
buffer As Long, ByVal pbSize As Long, pbSizeNeeded As Long) As Long
 
Public Declare Function SetPrinter Lib "winspool.drv" Alias _
"SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, _
pPrinter As Any, ByVal Command As Long) As Long
 
Public Declare Function DocumentProperties Lib "winspool.drv" _
Alias "DocumentPropertiesA" (ByVal hwnd As Long, _
ByVal hPrinter As Long, ByVal pDeviceName As String, _
ByVal pDevModeOutput As Long, ByVal pDevModeInput As Long, _
ByVal fMode As Long) As Long
 
Public Declare Function ClosePrinter Lib "winspool.drv" _
(ByVal hPrinter As Long) As Long
 
Public Const DM_IN_BUFFER = 8
Public Const DM_OUT_BUFFER = 2
 
 
Sub Print_Something()
 
Dim sPrinterName As String
Dim my_printer_address As String
Dim hPrinter As Long
Dim Pinfo9 As PRINTER_INFO_9
Dim dm As DEVMODE
Dim yDevModeData() As Byte
Dim nRet As Long
 
    
    'Display printer list for selection
    my_printer_address = Application.Dialogs(xlDialogPrinterSetup).Show
 
    If (my_printer_address = False) Then Exit Sub   'terminate early cause user has cancelled
 
    'slice string for printer name (minus port name)
    sPrinterName = Left(Application.ActivePrinter, InStr(Application.ActivePrinter, " on ") - 1)
 
    'Open Printer
    nRet = OpenPrinter(sPrinterName, hPrinter, ByVal 0&)
        
    'Get the size of the DEVMODE structure
    nRet = DocumentProperties(0, hPrinter, sPrinterName, 0, 0, 0)
    If (nRet < 0) Then
        MsgBox "Cannot get the size of the DEVMODE structure."
        Stop
    End If
     
    'Get DEVMODE Structure
    ReDim yDevModeData(nRet + 100) As Byte
    nRet = DocumentProperties(0, hPrinter, sPrinterName, _
    VarPtr(yDevModeData(0)), 0, DM_OUT_BUFFER)
    If (nRet < 0) Then
        MsgBox "Cannot get the DEVMODE structure."
        Stop
    End If
  
    'Copy the DEVMODE structure
    Call CopyMemory(dm, yDevModeData(0), Len(dm))
    
    'Change DEVMODE Stucture as required
    dm.dmDefaultSource = 4 'Selects the Bypas Tray
    
    'Replace the DEVMODE structure
    Call CopyMemory(yDevModeData(0), dm, Len(dm))
     
    'Verify DEVMODE Stucture
    nRet = DocumentProperties(0, hPrinter, sPrinterName, _
    VarPtr(yDevModeData(0)), VarPtr(yDevModeData(0)), _
    DM_IN_BUFFER Or DM_OUT_BUFFER)
 
    Pinfo9.pDevmode = VarPtr(yDevModeData(0))
    
    'Set DEVMODE Stucture with any changes made
    nRet = SetPrinter(hPrinter, 9, Pinfo9, 0)
    If (nRet <= 0) Then
        MsgBox "Cannot set the DEVMODE structure."
        Stop
    End If
 
    'Print selection
    Range("A1:D12").Select
    Selection.PrintOut Copies:=1
    
    'Close the Printer
    nRet = ClosePrinter(hPrinter)

End Sub

 

[asjeff]

Hi TopJack

One thing I found when using API's to set printer properties is that you need a Sys Admin who is willing to share the Printer Server to the Everyone security group, otherwise permissions will cripple all attempts to get anything to work (

On the upside I use API's to do what you require. I admit that I use this in Word, and I can get away with it simply because we only have 2 or 3 models of HP printers all with the PCL6 driver and nothing else. It might not be robust enough if you have large amounts of different printers/drivers etc.

Add the following into a standard module (for excel you will have to change any activedocument reference to Workbook/worksheet etc):

'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'
Private Const DC_BINS = 6
Private Const DC_BINNAMES = 12

Private Declare Function DeviceCapabilities Lib "winspool.drv" _
Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, _
ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, _
ByVal dev As Long) As Long

Public Function GetBinNumbers() As Variant
On Error GoTo GBN_Error:

'Code adapted from Microsoft KB article Q194789
'HOWTO: Determine Available PaperBins with DeviceCapabilities API
Dim iBinNos As Long
Dim iBinArray() As Integer
Dim sPort As String
Dim sCurrentPrinter As String

'Get the printer & port name of the current printer
sPort = Trim$(Mid$(ActivePrinter, InStrRev(ActivePrinter, " ") + 1))
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))

'Find out how many printer bins there are
iBinNos = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, ByVal vbNullString, 0)

'Set the array of bin numbers to the right size
ReDim iBinArray(0 To iBinNos - 1)

'Load the array with the bin numbers
iBinNos = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, iBinArray(0), 0)

'Return the array to the calling routine
GetBinNumbers = iBinArray

Exit Function

GBN_Error:
ErrMessage Err.Number, Err.Description, "modPrinterTrays_GetBinNumbers"

End Function

Public Function GetBinNames() As Variant
On Error GoTo GBName_Error:

'Code adapted from Microsoft KB article Q194789
'HOWTO: Determine Available PaperBins with DeviceCapabilities API

Dim iBinNames As Long
Dim ct As Long
Dim sNamesList As String
Dim sNextString As String
Dim sPort As String
Dim sCurrentPrinter As String
Dim vBinName As Variant

'Get the printer & port name of the current printer
sPort = Trim$(Mid$(ActivePrinter, InStrRev(ActivePrinter, " ") + 1))
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))

'Find out how many printer bins there are
iBinNames = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, ByVal vbNullString, 0)

'Set the string to the right size to hold all the bin names
'24 chars per name
sNamesList = String(24 * iBinNames, 0)

'Load the string with the bin names
iBinNames = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINNAMES, ByVal sNamesList, 0)

'Set the array of bin names to the right size
ReDim vBinName(0 To iBinNames - 1)
For ct = 0 To iBinNames - 1
'Get each bin name in turn and assign to the next item in the array
sNextString = Mid(sNamesList, 24 * ct + 1, 24)
vBinName(ct) = Left(sNextString, InStr(1, sNextString, Chr(0)) - 1)
Next ct

'Return the array to the calling routine
GetBinNames = vBinName

Exit Function

GBName_Error:
ErrMessage Err.Number, Err.Description, "modPrinterTrays_GetBinNames"

End Function

Public Function GetTrayInfo(sPrinterTrayDesc As String, Optional sTrayDesc2 As String, Optional sTrayDesc3 As String, Optional sTrayDesc4 As String) As Long
On Error GoTo GetTray_Error:

'Code adapted from Microsoft KB article Q194789
'HOWTO: Determine Available PaperBins with DeviceCapabilities API

Dim iBinNames As Long
Dim ct As Long
Dim sNamesList As String
Dim sNextString As String
Dim sPort As String
Dim sCurrentPrinter As String
Dim vBinName As Variant

Dim iBinNos As Long
Dim iBinArray() As Integer

Dim iTrayNumber As Integer

'Get the printer & port name of the current printer
sPort = Trim$(Mid$(ActivePrinter, InStrRev(ActivePrinter, " ") + 1))
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))

'Find out how many printer bins there are
iBinNos = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, ByVal vbNullString, 0)

'Set the array of bin numbers to the right size
ReDim iBinArray(0 To iBinNos - 1)

'Load the array with the bin numbers
iBinNos = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, iBinArray(0), 0)

'Get the printer & port name of the current printer
sPort = Trim$(Mid$(ActivePrinter, InStrRev(ActivePrinter, " ") + 1))
sCurrentPrinter = Trim$(Left$(ActivePrinter, InStr(ActivePrinter, " on ")))

'Find out how many printer bins there are
iBinNames = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINS, ByVal vbNullString, 0)

'Set the string to the right size to hold all the bin names
'24 chars per name
sNamesList = String(24 * iBinNames, 0)

'Load the string with the bin names
iBinNames = DeviceCapabilities(sCurrentPrinter, sPort, DC_BINNAMES, ByVal sNamesList, 0)


'Set the array of bin names to the right size
ReDim vBinName(0 To iBinNames - 1)
For ct = 0 To iBinNames - 1
'Get each bin name in turn and assign to the next item in the array
sNextString = Mid(sNamesList, 24 * ct + 1, 24)
vBinName(ct) = Left(sNextString, InStr(1, sNextString, Chr(0)) - 1)
'have specified three names here because different printers show the "Automatically Select" option in different ways
If Trim(vBinName(ct)) = sPrinterTrayDesc Or Trim(vBinName(ct)) = sTrayDesc2 Or Trim(vBinName(ct)) = sTrayDesc3 Or Trim(vBinName(ct)) = sTrayDesc4 Then
iTrayNumber = iBinArray(ct)
GetTrayInfo = iTrayNumber
Exit Function
End If
Next ct

'If nothing set then try and set it to a standard bin
GetTrayInfo = ActiveDocument.PageSetup.FirstPageTray = wdPrinterDefaultBin

Exit Function

GetTray_Error:
ErrMessage Err.Number, Err.Description, "modPrinterTrays_GetTrayInfo"

End Function
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~'


And then you can set the trays as desired by calling them as follows: (this is for Word - you will have to amend in Excel):

ActiveDocument.PageSetup.FirstPageTray = GetTrayInfo("Tray 3", "Tray 3 (500-Sheet)")

ActiveDocument.PageSetup.OtherPagesTray = GetTrayInfo("Tray 2")

Not exactly for the purists but it works for me. Hope it helps.

Asjeff

 

[TopJack]

Thanks Asjeff. Very useful.