If you have not read the explanation of this code then click here.

mForms Module (Contains TVP Print Subroutine):

Public Sub TvpPrint()

mPrint.GetBinNumbers
mPrint.GetBinNames
frmPrint.Show
End Sub

mPrint Module (Contains GetBinNumbers & GetBinNames Functions and OnePlusOne, SingleHeaded, InsertDate and Test Subroutines):

Option Explicit
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
Dim trayheaded As Integer
Dim trayplain As Integer

Public Function GetBinNumbers() As Variant
'Code adapted from Microsoft KB article 194789
'HOWTO: Determine Available PaperBins with DeviceCapabilities API

Dim iBins As Long
Dim iBinArray() As Integer
Dim sPort As String
Dim sCurrentPrinter As String
Dim PrinterType As String
Dim traytype As Integer
Dim count As Integer
Dim PrinterModel As String
Dim TrayCount As Long

'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
iBins = DeviceCapabilities(sCurrentPrinter, sPort, _
DC_BINS, ByVal vbNullString, 0)

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

'Load the array with the bin numbers

iBins = DeviceCapabilities(sCurrentPrinter, sPort, _
DC_BINS, iBinArray(0), 0)

'Return the array to the calling routine
GetBinNumbers = iBinArray

PrinterInfo.ListBox1.List = GetBinNumbers

PrinterModel = "not set up for use with this function." 'Default value for any printers not recognised below
TrayCount = UBound(iBinArray) 'Maximum number of paper trays
For count = 0 To TrayCount
traytype = iBinArray(count) 'Search through array for all tray numbers

If traytype = 283 Then PrinterModel = "an OKI 20/24"
If traytype = 1265 Then PrinterModel = "a HP 4200tn"
If traytype = 1 Then PrinterModel = "Word Standard (HP4100/LJIII, etc.)"
If traytype = 11 Then PrinterModel = "a HP4100tn"
Next

'Note that STANDARD applies to HP4100 Printer and other printers that use Word constants
'HP4100tn uses a different tray number to the 4100 hence the two entries
'Tally T9116D needs to use a HP LaserJet IIIP driver to prevent a clash with the HP4200
'Amend the above list for any new makes/model of printer to be used

'Set up trays for Oki 20/24
If PrinterModel = "an OKI 20/24" Then
trayheaded = 285
trayplain = 283
End If

'Set up trays for HP4200tn
If PrinterModel = "a HP 4200tn" Then
trayheaded = 1265
trayplain = 1267
End If

'Set up trays for HP4100 (Large Capacity Tray)
If PrinterModel = "a HP4100tn" Then
trayheaded = 11
trayplain = 2
End If

'Set up trays for printers using standard Word constants (such as the HP 4100 & LJIIIP)
If PrinterModel = "Word Standard (HP4100/LJIII, etc.)" Then
trayheaded = 2
trayplain = 1
End If

'Set up trays using Word default values for unrecognised/unsuitable printers
If PrinterModel = "not set up for use with this function." Then
trayheaded = 2
trayplain = 1
End If

frmPrint.Label1 = PrinterModel
End Function

Public Function GetBinNames() As Variant

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

Dim iBins As Long
Dim ct As Long
Dim sNamesList As String
Dim sNextString As String
Dim sPort As String
Dim sCurrentPrinter As String
Dim vBins 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
iBins = 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 * iBins, 0)

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

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

'Return the array to the calling routine
GetBinNames = vBins
PrinterInfo.ListBox2.List = GetBinNames
End Function

Public Sub OnePlusOne()

Dim trayh As String
Dim trayp As String
Dim copies As String
Dim copynum As Integer

copies = frmPrint.CopiesBox.Text
copynum = CInt(copies) 'Convert String to Inetger

'current tray setting
trayh = ActiveDocument.PageSetup.FirstPageTray
trayp = ActiveDocument.PageSetup.OtherPagesTray

Do Until copynum = 0

'headed copy

With ActiveDocument.PageSetup
.FirstPageTray = trayheaded
.OtherPagesTray = trayplain
End With

ActiveDocument.PrintOut
'plain copy

With ActiveDocument.PageSetup
.FirstPageTray = trayplain
.OtherPagesTray = trayplain
End With
ActiveDocument.PrintOut
copynum = copynum - 1
Loop

'restore trays to original settings
ActiveDocument.PageSetup.FirstPageTray = trayh
ActiveDocument.PageSetup.OtherPagesTray = trayp

End Sub

Public Sub SingleHeaded()

Dim trayh As String
Dim trayp As String
Dim copies As String
Dim copynum As Integer

copies = frmPrint.CopiesBox.Text
copynum = CInt(copies) 'Convert String to Inetger

'current tray setting
trayh = ActiveDocument.PageSetup.FirstPageTray
rayp = ActiveDocument.PageSetup.OtherPagesTray

'headed copy
Do Until copynum = 0
With ActiveDocument.PageSetup
.FirstPageTray = trayheaded
.OtherPagesTray = trayplain
End With
copynum = copynum - 1
ActiveDocument.PrintOut
Loop
'restore trays to original settings
ActiveDocument.PageSetup.FirstPageTray = trayh
ActiveDocument.PageSetup.OtherPagesTray = trayp
End Sub

Public Sub Insertdate()
Selection.InsertDateTime DateTimeFormat:="dd MMMM yyyy", InsertAsField:= _
False, DateLanguage:=wdEnglishUK, CalendarType:=wdCalendarWestern, _
InsertAsFullWidth:=False
End Sub

Public Sub Test()
Dialogs(wdDialogToolsOptionsFileLocations).Show
End Sub

mShortcutnocopy Module (contains CTRLALTP subroutine):

Sub CTRLALTP()
'
' CTRLSHIFTP Macro
' Macro created 27/08/2003 by D Savery
GetBinNumbers
SingleHeaded
End Sub

mShortcutwcopy Module (contains CTRLSHIFTP subroutine):

Sub CTRLSHIFTP()
' CTRLSHIFTP Macro

' Macro created 21/08/2003 by D Savery
GetBinNumbers
OnePlusOne
End Sub

Version Module (contains version subroutine):

Sub Version()
' Version Macro
' Macro created 02/03/04 by David Savery
MsgBox "Normal.dot Template Version 3.7 02/03/04 by R3"
End Sub

PrinterInfo Form (activated when the About button is pressed):

Private Sub ListBox1_Click()
End Sub

Private Sub ListBox2_Click()
End Sub

Private Sub UserForm_Click()
End Sub

Private Sub CmdOk_Click()
Unload Me
End Sub

The layout of the printer Info Form

frmprint Form (activated by TVP Print macro):

Private Sub CmdAbout_Click()
PrinterInfo.Show
End Sub

Private Sub CmdCancel_Click()
Unload Me
End Sub

Private Sub CmdOk_Click()

'Set print trays for 1+1
If OptPrint.Value = True Then
OnePlusOne
End If

'Set print trays for single headed

If OptHed.Value = True Then
SingleHeaded
End If

'Enter todays date
If OptDate.Value = True Then
Insertdate
End If

Unload Me
End Sub

Private Sub CopiesBox_Change()
End Sub

Private Sub Label2_Click()
End Sub

Private Sub Label3_Click()
End Sub

Private Sub UserForm_Click()
End Sub

The frmprint UserForm dialogue box

Return to parent article