spool.bas

很好的教程原代码！

Attribute VB_Name = "MSpool"
Option Explicit
'
Private Declare Function GetProfileString Lib "kernel32" Alias "GetProfileStringA" _
    (ByVal lpAppName As String, _
    ByVal lpKeyName As Any, _
    ByVal lpDefault As String, _
    ByVal lpReturnedString As String, _
    ByVal nSize As Long _
    ) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" _
    (ByVal pPrinterName As String, _
    phPrn As Long, pDefault As Any _
    ) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" _
    (ByVal hPrn As Long, _
    ByVal Level As Long, _
    pDocInfo As DOC_INFO_1 _
    ) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" _
    (ByVal hPrn As Long _
    ) As Long
Private Declare Function WritePrinter Lib "winspool.drv" _
    (ByVal hPrn As Long, _
    pBuf As Any, _
    ByVal cdBuf As Long, _
    pcWritten As Long _
    ) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" _
    (ByVal hPrn As Long _
    ) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" _
    (ByVal hPrn As Long _
    ) As Long
Private Declare Function ClosePrinter Lib "winspool.drv" _
    (ByVal hPrn As Long _
    ) As Long
'类型声明
Private Type DOC_INFO_1
    pDocName As String
    pOutputFile As String
    pDatatype As String
End Type

Public Sub SelectDefaultPrinter(Lst As ComboBox)
    Dim sRet As String
    Dim nRet As Integer
    Dim i As Integer
    '
    ' 在WIN.INI文件中查找默认的打印机
    '
    sRet = Space(255)
    nRet = GetProfileString("Windows", ByVal "device", "", _
                            sRet, Len(sRet))
    '
    ' 除去默认打印机名
    '
    If nRet Then
        sRet = UCase(Left(sRet, InStr(sRet, ",") - 1))
        For i = 0 To Lst.ListCount
            If Left(UCase(Lst.List(i)), Len(sRet)) = sRet Then
                Lst.ListIndex = i
                Exit For
            End If
        Next i
    End If
End Sub
'
Public Sub SpoolFile(sFile As String, PrnName As String, Optional AppName As String = "")
    Dim hPrn As Long
    Dim Buffer() As Byte
    Dim hFile As Integer
    Dim Written As Long
    Dim di As DOC_INFO_1
    Dim i As Long
    Const BufSize As Long = &H4000
    '
    If InStr(sFile, "\") Then
        For i = Len(sFile) To 1 Step -1
            If Mid(sFile, i, 1) = "\" Then Exit For
            di.pDocName = Mid(sFile, i, 1) & di.pDocName
        Next i
    Else
        di.pDocName = sFile
    End If
    If Len(AppName) Then
        di.pDocName = AppName & ": " & di.pDocName
    End If
    di.pOutputFile = vbNullString
    di.pDatatype = "RAW"
    '
    ' 打开打印机
    ' 使打印机接收原始数据
    '
    Call OpenPrinter(PrnName, hPrn, vbNullString)
    Call StartDocPrinter(hPrn, 1, di)
    Call StartPagePrinter(hPrn)
    '
    ' 打开文件
    '
    hFile = FreeFile
    Open sFile For Binary Access Read As hFile
       '
       ' 读入16K内容并打印
       '
       ReDim Buffer(1 To BufSize) As Byte
       For i = 1 To LOF(hFile) \ BufSize
          Get #hFile, , Buffer
          Call WritePrinter(hPrn, Buffer(1), BufSize, Written)
       Next i
       '
       ' 获取最后不足16K的内容
       '
       If LOF(hFile) Mod BufSize Then
          ReDim Buffer(1 To (LOF(hFile) Mod BufSize)) As Byte
          Get #hFile, , Buffer
          Call WritePrinter(hPrn, Buffer(1), UBound(Buffer), Written)
       End If
    Close #hFile
    '
    ' 关闭打印进程
    '
    Call EndPagePrinter(hPrn)
    Call EndDocPrinter(hPrn)
    Call ClosePrinter(hPrn)
End Sub
'
Public Function IsFile(SpecIn As String) As Boolean
   Dim Attr As Byte
   On Error Resume Next
   Attr = GetAttr(SpecIn)
   If Err = 0 Then
      If (Attr And vbDirectory) = vbDirectory Then
         IsFile = False
      Else
         IsFile = True
      End If
   End If
End Function