Set Printer By Paper Dimensions

Option Compare Database
Option Explicit

  Public Enum DeviceCapabilitiesFlags
    DC_FIELDS = 1
    DC_PAPERS = 2
    DC_PAPERSIZE = 3
    DC_MINEXTENT = 4
    DC_MAXEXTENT = 5
    DC_BINS = 6
    DC_DUPLEX = 7
    DC_SIZE = 8
    DC_EXTRA = 9
    DC_VERSION = 10
    DC_DRIVER = 11
    DC_BINNAMES = 12
    DC_ENUMRESOLUTIONS = 13
    DC_FILEDEPENDENCIES = 14
    DC_TRUETYPE = 15
    DC_PAPERNAMES = 16
    DC_ORIENTATION = 17
    DC_COPIES = 18
    DC_BINADJUST = 19
    DC_EMF_COMPLIANT = 20
    DC_DATATYPE_PRODUCED = 21
    DC_COLLATE = 22
    DC_MANUFACTURER = 23
    DC_MODEL = 24
    DC_PERSONALITY = 25
    DC_PRINTRATE = 26
    DC_PRINTRATEUNIT = 27
    DC_PRINTERMEM = 28
    DC_MEDIAREADY = 29
    DC_STAPLE = 30
    DC_PRINTRATEPPM = 31
    DC_COLORDEVICE = 32
    DC_NUP = 33
    DC_MEDIATYPENAMES = 34
    DC_MEDIATYPES = 35
End Enum
Public Enum LabelType
lt8_5x11 = 0
lt3x2 = 1
lt1_5x1 = 2
End Enum

Public Type POINT
    x As Long
    y As Long
End Type

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

Public Declare Function StrLen _
  Lib "kernel32.dll" _
    Alias "lstrlenA" _
      (ByVal lpString As String) _
    As Long

Public Function GetPrinterNameByPaperDimensions(ByRef argIn As LabelType, Optional ByVal argColor As Boolean) As String
    Dim defaultPrinter() As String
    Dim paperCount As Long
    Dim NameArray() As Byte
    Dim i As Long
    Dim paperNames() As String
    Dim paperName As String
    Dim ctr As Long
    Dim AllNames As Variant
    Dim p As Printer
    Dim PIn As POINT
    Dim out As String
    out = ""
    PIn = GetPaperXY(argIn)
    If Not (PIn.x = 0 And PIn.y = 0) Then
        For Each p In Application.Printers
            ctr = 0
            If Not (p.DeviceName Like "*eprint*" Or p.DeviceName Like "*oneNote*" Or p.DeviceName Like "*xps*" Or p.DeviceName Like "*fax*" Or p.DeviceName Like "*pdf*") Then
                'defaultPrinter = Split(Application.Printer, " on ")
                paperCount = DeviceCapabilities(p.DeviceName, p.Port, DC_PAPERSIZE, ByVal 0&, ByVal 0&)
                ReDim paperNames(1 To paperCount)
                ReDim NameArray(0 To paperCount * 64) As Byte
                ' Get paper names
                paperCount = DeviceCapabilities(p.DeviceName, p.Port, DC_PAPERNAMES, NameArray(0), 0)
                'convert the retrieved byte array to an ANSI string
                AllNames = StrConv(NameArray, vbUnicode)
                'ReDim PaperSizes(1 To paperCount)
                ReDim paperNames(1 To paperCount)
                'loop through the string and search for the names of the papers
                For i = 1 To Len(AllNames) Step 64
                    ctr = ctr + 1
                    paperName = Mid(AllNames, i, 64)
                    paperName = Left(paperName, StrLen(paperName))
                    If paperName <> vbNullString Then
                        paperNames(ctr) = paperName
                    End If
                Next i
                ReDim papersizes(1 To paperCount) As POINT
                paperCount = DeviceCapabilities(p.DeviceName, p.Port, DC_PAPERSIZE, papersizes(1), 0)
                For i = 1 To paperCount
                    If papersizes(i).x = PIn.x And papersizes(i).y = PIn.y Then
                        out = p.DeviceName
                        Exit For
                    End If
                Next
            End If
        Next
    End If
    GetPrinterNameByPaperDimensions = out
End Function

Public Function GetPaperXY(argIn As LabelType) As POINT
    'dimensions are in 10ths of a milimeter
    'lt8_5x11 = 0
    'lt3x2 = 1
    'lt1_5x1 = 2
    Dim p As POINT
    p.x = 0
    p.y = 0
    'cant just store the point in the dictionary since it wants a class. this seems to be a good compramise.
    Const conversionFactor As Long = 254
    Static x As Object
    Static y As Object
    If x Is Nothing Then
        Set x = CreateObject("Scripting.Dictionary")
        x.add lt8_5x11, 8.5 * conversionFactor
        x.add lt3x2, 3 * conversionFactor
        x.add lt1_5x1, 1.5 * conversionFactor
    End If
    If y Is Nothing Then
        Set y = CreateObject("Scripting.Dictionary")
        y.add lt8_5x11, 11 * conversionFactor
        y.add lt3x2, 2 * conversionFactor
        y.add lt1_5x1, 1 * conversionFactor
    End If
    p.x = x(argIn)
    p.y = y(argIn)
    GetPaperXY = p
End Function