_modprinter.bas

功能强大的API

Attribute VB_Name = "modPrinter"
'****************************************
'汉化: 小聪明       [e-mail]
'小聪明的主页VB版:  http://coolzm.533.net
'****************************************
Option Explicit
'------------------------------------------------------------
' SC Productions
' Name: RFN
' Company: SCP
' Purpose: Mod for all Printer const, types, and declairs
' Parameters: varies
' Date: June,24 99
'------------------------------------------------------------
Public Const NULLPTR = 0&
Public Const CCHDEVICENAME = 32
Public Const CCHFORMNAME = 32
Public Const DM_MODIFY = 8
Public Const DM_COPY = 2
Public Const DM_IN_BUFFER = DM_MODIFY
Public Const DM_OUT_BUFFER = DM_COPY
Public Const DMORIENT_PORTRAIT = 1
Public Const DMORIENT_LANDSCAPE = 2
'关于打印质量的常数
Public Const DMRES_DRAFT = (-1)
Public Const DMRES_HIGH = (-4)
Public Const DMRES_LOW = (-2)
Public Const DMRES_MEDIUM = (-3)

Public Const DMTT_BITMAP = 1
Public Const DMTT_DOWNLOAD = 2
Public Const DMTT_DOWNLOAD_OUTLINE = 4
Public Const DMTT_SUBDEV = 3
Public Const DMCOLOR_COLOR = 2
Public Const DMCOLOR_MONOCHROME = 1

Public Type DEVMODE
    dmDeviceName(1 To CCHDEVICENAME) As Byte
    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(1 To CCHFORMNAME) As Byte
    dmUnusedPadding As Integer
    dmBitsPerPel As Integer
    dmPelsWidth As Long
    dmPelsHeight As Long
    dmDisplayFlags As Long
    dmDisplayFrequency As Long
End Type


Public Declare Function OpenPrinter Lib "winspool.drv" Alias _
        "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, _
        ByVal pDefault 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, _
        pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) _
        As Long

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

Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
        (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)

Private Declare Function GetProfileString Lib "kernel32" Alias _
        "GetProfileStringA" (ByVal lpAppName As String, _
        ByVal lpKeyName As String, ByVal lpDefault As String, _
        ByVal lpReturnedString As String, _
        ByVal nSize As Long) As Long

Private Declare Function EnumDisplaySettings Lib _
        "user32" Alias "EnumDisplaySettingsA" _
        (ByVal lpszDeviceName As Long, ByVal iModeNum As Long, _
        lpDevMode As Any) As Boolean

Public Sub EnumDisplay()

    Dim lTemp As Long, tDevMode As DEVMODE, lIndex As Long
    lIndex = 0
    Do
        lTemp = EnumDisplaySettings(0&, lIndex, tDevMode)
    
        If lTemp = 0 Then Exit Do
        With tDevMode
            FormSSI.List1.AddItem .dmPelsWidth & " pixels by " _
                    & .dmPelsHeight & " pixels, Color Mode " _
                    & .dmBitsPerPel & " bit"
            'Debug.Print .dmPelsWidth & " pixels by " _
             '& .dmPelsHeight & " pixels, Color Mode " _
             '& .dmBitsPerPel & " bit"
  
        End With

        lIndex = lIndex + 1
    Loop
End Sub
'------------------------------------------------------------
' Name: Nall
' Company: SC Productions
' Purpose: Retrive the printer settings
' Parameters: As shown below
' Date: June,01 99' Time: 21:47
'------------------------------------------------------------
Private Function StripNulls(startStrg As String) As String
    Dim c As Integer
    Dim item As String
    c = 1
    Do
        If Mid(startStrg, c, 1) = Chr(0) Then
            item = Mid(startStrg, 1, c - 1)
            startStrg = Mid(startStrg, c + 1, Len(startStrg))
            StripNulls = item
            Exit Function
        End If
        c = c + 1
    Loop
End Function
Function ByteToString(ByteArray() As Byte) As String
    Dim TempStr As String
    Dim i As Integer

    For i = 1 To CCHDEVICENAME
        TempStr = TempStr & Chr(ByteArray(i))
    Next i
    ByteToString = StripNulls(TempStr)
End Function
Function GetPrinterSettings(szPrinterName As String, hdc As Long) _
            As Boolean
    On Error GoTo Err
    Dim hPrinter As Long
    Dim nSize As Long
    Dim pDevMode As DEVMODE
    Dim aDevMode() As Byte
    Dim TempStr As String

    If OpenPrinter(szPrinterName, hPrinter, NULLPTR) Then
        nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
                NULLPTR, NULLPTR, 0)
        ReDim aDevMode(1 To nSize)
        nSize = DocumentProperties(NULLPTR, hPrinter, szPrinterName, _
                aDevMode(1), NULLPTR, DM_OUT_BUFFER)
        Call CopyMemory(pDevMode, aDevMode(1), Len(pDevMode))

        FormSSI.List2.Clear
        FormSSI.List2.AddItem "Printer Name: " & _
                ByteToString(pDevMode.dmDeviceName)

        If pDevMode.dmOrientation = DMORIENT_PORTRAIT Then
            TempStr = "PORTRAIT"
        ElseIf pDevMode.dmOrientation = DMORIENT_LANDSCAPE Then
            TempStr = "LANDSCAPE"
        Else
            TempStr = "UNDEFINED"
        End If
        FormSSI.List2.AddItem "Orientation: " & TempStr

        Select Case pDevMode.dmPrintQuality
            Case DMRES_DRAFT
                TempStr = "DRAFT"
            Case DMRES_HIGH
                TempStr = "HIGH"
            Case DMRES_LOW
                TempStr = "LOW"
            Case DMRES_MEDIUM
                TempStr = "MEDIUM"
            Case Else
                TempStr = CStr(pDevMode.dmPrintQuality) & " dpi"
        End Select
        FormSSI.List2.AddItem "Print Quality: " & TempStr

        Select Case pDevMode.dmTTOption
            Case DMTT_BITMAP
                TempStr = "TrueType fonts as graphics"
            Case DMTT_DOWNLOAD
                TempStr = "Downloads TrueType fonts as soft fonts"
            Case DMTT_SUBDEV
                TempStr = "Substitute device fonts for TrueType fonts"
            Case Else
                TempStr = "UNDEFINED"
        End Select
        FormSSI.List2.AddItem "TrueType Option: " & TempStr

        If pDevMode.dmColor = DMCOLOR_MONOCHROME Then
            TempStr = "MONOCHROME"
        ElseIf pDevMode.dmColor = DMCOLOR_COLOR Then
            TempStr = "COLOR"
        Else
            TempStr = "UNDEFINED"
        End If
        FormSSI.List2.AddItem "Color or Monochrome: " & TempStr

        If pDevMode.dmScale = 0 Then
            TempStr = "NONE"
        Else
            TempStr = CStr(pDevMode.dmScale)
        End If
        FormSSI.List2.AddItem "Scale Factor: " & TempStr

        FormSSI.List2.AddItem "Y Resolution: " & pDevMode.dmYResolution & " dpi"
        FormSSI.List2.AddItem "Copies: " & CStr(pDevMode.dmCopies)


        Call ClosePrinter(hPrinter)
        GetPrinterSettings = True
    Else
        GetPrinterSettings = False
    End If

Err:
    If Err.Number = 0 Then
        Exit Function
    Else
        WriteError Err.Number, Err.Description, "Get Printer Settings", Now, App.Path & "\err.log"
        MsgBox Err.Description, vbCritical + vbOKOnly, "Get Printer Settings"
    End If

End Function

Public Function GetDefaultPrinter() As Printer
    On Error GoTo Err
    Dim strBuffer As String * 254
    Dim iRetValue As Long
    Dim strDefaultPrinterInfo As String
    Dim tblDefaultPrinterInfo() As String
    Dim objPrinter As Printer
    '返回当前默认的打印机的信息
      iRetValue = GetProfileString("windows", "device", ",,,", strBuffer, 254)
    strDefaultPrinterInfo = Left(strBuffer, InStr(strBuffer, Chr(0)) - 1)
    tblDefaultPrinterInfo = Split(strDefaultPrinterInfo, ",")
    For Each objPrinter In Printers
        If objPrinter.DeviceName = tblDefaultPrinterInfo(0) Then
            ' 找到打印机
            Exit For
        End If
    Next

    If objPrinter.DeviceName <> tblDefaultPrinterInfo(0) Then
        Set objPrinter = Nothing '没找到打印机
    End If

    Set GetDefaultPrinter = objPrinter
Err:
    If Err.Number = 0 Then
        Exit Function
    Else
        WriteError Err.Number, Err.Description, "Get Default Printer", Now, App.Path & "\err.log"
        Exit Function
        'MsgBox Err.Description, vbCritical + vbOKOnly, "Get Default Printer"
    End If

End Function