getpaper.bas

guan yu pai ke xi tong de ruan jian

Attribute VB_Name = "GetPaper"
'获取打印机纸张信息
Option Explicit
Private Const DC_MAXEXTENT = 5
Private Const DC_MINEXTENT = 4
Private Const DC_PAPERNAMES = 16
Private Const DC_PAPERS = 2
Private Const DC_PAPERSIZE = 3
Private Declare Function DeviceCapabilities Lib "winspool.drv" Alias "DeviceCapabilitiesA" (ByVal lpDeviceName As String, ByVal lpPort As String, ByVal iIndex As Long, lpOutput As Any, lpDevMode As Any) As Long
Public Type PaperInfo '一个表示纸张的数据类型。
    PaperSize As Integer '纸张编号。
    PaperName As String '纸张名称。
    PaperWidth As Long '纸张宽度。
    PaperHeight As Long '纸张高度。
    PaperListIndex As Integer '纸张索引号。
    PaperListCount As Integer '纸张总数。
    GetPaperErr As Boolean '表征是否执行成功(成功为False,失败为True)。
End Type
Private Type POINTS
    X As Long
    Y As Long
End Type
'***********************************************************
'*   名称：GetPaperInfo
'*   功能：得到打印机低张信息
'*   用法：GetPaperInfo(PaperInfo数据结构变量)
'*   描述：如在   form_load()中调用GetPaperInfo   PaperInfo
'*   说明：PaperInfo为自定义数据结构。其中的PaperListIndex用于指定要取得的纸张的索引,如果该值为0表示取打印机当前的纸张信息。
'***********************************************************
Public Function GetPaperInfo(OutPaperInfo As PaperInfo) As Boolean
On Error GoTo GetPaperErr
    Dim i     As Long, ret       As Long
    Dim Length     As Integer, Width       As Integer
    Dim PaperNo()     As Integer, PaperName()       As String, PaperSize()       As POINTS
    Dim NowPaperIndex As Integer '指打印机当前纸张引起（从1开始）
    '支持最大打印纸：
    'ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MAXEXTENT, ByVal 0&, ByVal 0&)
    'Length = ret \ 65536
    'Width = ret - Length * 65536
      
    '支持最小打印纸：
    'ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_MINEXTENT, ByVal 0&, ByVal 0&)
    'Length = ret \ 65536
    'Width = ret - Length * 65536
      
    '支持纸张种类数
    OutPaperInfo.GetPaperErr = False
    ret = DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, ByVal 0&, ByVal 0&)
    OutPaperInfo.PaperListCount = ret '保存纸张种类数。
    If OutPaperInfo.PaperListIndex > ret Then GoTo GetPaperErr  '指定的纸张索引超出系统打印机支持的数量,则出错返回。
    '纸张编号
    ReDim PaperNo(1 To ret) As Integer
    Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERS, PaperNo(1), ByVal 0&)
    '纸张名称
    Dim arrPageName()     As Byte
    Dim allNames     As String
    Dim lStart     As Long, lEnd       As Long
    ReDim PaperName(1 To ret) As String
    ReDim arrPageName(1 To ret * 64) As Byte
    Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERNAMES, arrPageName(1), ByVal 0&)
    allNames = StrConv(arrPageName, vbUnicode) '将字节数组转换为字符串。
    i = 1
    Do '依次取出各字符串。
        lEnd = InStr(lStart + 1, allNames, Chr$(0), vbBinaryCompare)
        If (lEnd > 0) And (lEnd - lStart - 1 > 0) Then
            PaperName(i) = Mid$(allNames, lStart + 1, lEnd - lStart - 1)
            i = i + 1
        End If
        lStart = lEnd
    Loop Until lEnd = 0
    '纸张尺寸
    ReDim PaperSize(1 To ret) As POINTS
    Call DeviceCapabilities(Printer.DeviceName, "LPT1", DC_PAPERSIZE, PaperSize(1), ByVal 0&)
    If OutPaperInfo.PaperListIndex <= 0 Then '表示取打印机的当前纸张信息。
        For i = 1 To OutPaperInfo.PaperListCount
            If PaperNo(i) = Printer.PaperSize Then
                OutPaperInfo.PaperListIndex = i
                Exit For
            End If
        Next
    End If
    OutPaperInfo.PaperSize = PaperNo(OutPaperInfo.PaperListIndex) '保存指定的纸张编号。
    OutPaperInfo.PaperName = PaperName(OutPaperInfo.PaperListIndex) '保存指定的纸张名称。
    OutPaperInfo.PaperWidth = PaperSize(OutPaperInfo.PaperListIndex).X '保存纸张宽度。
    OutPaperInfo.PaperHeight = PaperSize(OutPaperInfo.PaperListIndex).Y '保存纸张高度。
    Exit Function
GetPaperErr:
    OutPaperInfo.GetPaperErr = True
    'MsgBox Err.Description, vbOKOnly, "错误..."
End Function