VB下逐行打印的实现方法

用过Windows的人都知道，几乎所有软件，Word也好，Excel也好，AutoCAD也好，在打印的时候，一旦按下【打印】按钮，打印机就会开始动作，然后整页纸会被送入打印机，哪怕这张纸上仅有一个字也是如此。这就是所谓的“按页”打印，。嗯，是的，这在一般情况下似乎也没有什么问题。但是，有的场合就不行了，比如票据打印，还有打印一些流水帐之类的东西，总不至于打一份记录就用一整页纸这么夸张吧，所以我们必须找到一个“按行”打印的方法，当打印机打完一行后，并不执行出纸动作，而是停留在下一行的位置待命。因此我编写了这个类，以方便需要用到“按行”打印的人士使用。

------------------------------------------------------

简单讲一下原理，我们都知道Windows程序在打印的时候都有一个“打印到文件”的功能，这个功能可以讲打印的内容存为一种后缀为.PRN的文件，很多工具都能浏览这种文件，比如Adobe的PageMaker。

当我们生成了.PRN文件（而不是实质打印后），就能对文件本身进行修改，根据我的实验，发现该文件最后三个字节为“出纸”命令。Windows打印每次都换页的秘密就在于此，简单的，我们只需要将这三个字节删除，打印机就不会执行“出纸”命令了。

接着，我们将处理后的.PRN（最后三个字节被删除）文件用常规的方法再实质性（也就是启动打印机）打印一遍，打印机因为收不到“出纸”指令，所以它打完一行之后如果没有新的内容，它就会卡在原处不动，除非有新的内容需要它再次启动。

至此，完成“按行”打印的目的。

 

 

下面给出一个使用这个类的范例：

Dim LBL As New clsLBLPrn  '创建一个新的clsLBLPrn 类实例

LBL.StartDocs '开始一个新的打印任务

LBL.CurrentX = 30 'X坐标设置

 LBL.CurrentY = 70 'Y坐标设置

LBL.FontSize = 20 '设置字号

LBL.PrintText "I LOVE WWW.STONEREN.COM " '打印文字

LBL.PrintLine 1, 1, 100,100 '画一条从坐标1,1到100,100的直线

LBL.EndDocs   '开始打印

------------------------------------------------------

说明：
1. 本程序只使用于针式打印机
2. 本程序所使用的长度单位为“像素”

------------------------------------------------------

首先按常规方法添加向工程里添加一个类，取名为clsLBLPrn，并将以下内容复制进去：

' *************************************************************
' LBL (Line By Line) Print class
' 2004.06.01 Written By Rockage(Yang Hua)
' http://www.rockags.com http://www.stoneren.com
' email: [e-mail]
' *************************************************************
' Author grants royalty-free rights to use this code.
' *************************************************************
Option Explicit

Private Type DOCINFO
cbSize As Long
lpszDocName As String
lpszOutput As String
lpszDatatype As String
fwType As Long
End Type

Private Type DOC_INFO_1
pDocName As String
pOutputFile As String
pDatatype As String
End Type

Private Type POINT_TYPE
x As Long
y As Long
End Type

Private Type LOGFONT
lfHeight As Long
lfWidth As Long
lfEscapement As Long
lfOrientation As Long
lfWeight As Long
lfItalic As Byte
lfUnderline As Byte
lfStrikeOut As Byte
lfCharSet As Byte
lfOutPrecision As Byte
lfClipPrecision As Byte
lfQuality As Byte
lfPitchAndFamily As Byte
lfFaceName As String * 32
End Type

'Drawing API:
Private Declare Function CreateFontIndirect Lib "gdi32.dll" Alias "CreateFontIndirectA" (lplf As LOGFONT) As Long
Private Declare Function SelectObject Lib "gdi32.dll" (ByVal hdc As Long, ByVal hObject As Long) As Long
Private Declare Function TextOut Lib "gdi32" Alias "TextOutA" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, ByVal lpString As String, ByVal nCount As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Private Declare Function CreatePen Lib "gdi32.dll" (ByVal fnPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Declare Function MoveToEx Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long, lpPoint As POINT_TYPE) As Long
Private Declare Function LineTo Lib "gdi32.dll" (ByVal hdc As Long, ByVal x As Long, ByVal y As Long) As Long

'Printer API:
Private Declare Function DeleteDC Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function CreateDC Lib "gdi32.dll" Alias "CreateDCA" (ByVal lpszDriver As String, ByVal lpszDevice As String, ByVal lpszOutput As Long, lpInitData As Any) As Long
Private Declare Function StartPage Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function StartDoc Lib "gdi32.dll" Alias "StartDocA" (ByVal hdc As Long, lpdi As DOCINFO) As Long
Private Declare Function EndPage Lib "gdi32.dll" (ByVal hdc As Long) As Long
Private Declare Function EndDoc Lib "gdi32.dll" (ByVal hdc As Long) As Long
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 lf As LOGFONT, itsCurrentX As Long, itsCurrentY As Long
Private pt As POINT_TYPE
Private ret As Long
Private hPrintDC As Long
Private di As DOCINFO
Private prnName As String, strDOC As Boolean

Public Property Let CurrentY(ByVal vNewValue As Long)
itsCurrentY = vNewValue
End Property

Public Property Let CurrentX(ByVal vNewValue As Long)
itsCurrentX = vNewValue
End Property

Public Property Let FontSize(ByVal vNewValue As Long)
lf.lfHeight = vNewValue
End Property

Public Sub PrintLine(ByVal X1 As Long, ByVal Y1 As Long, ByVal X2 As Long, ByVal Y2 As Long)
MoveToEx hPrintDC, X1, Y1, pt
LineTo hPrintDC, X2, Y2
End Sub

Public Sub PrintText(ByVal strText As String)
Dim hFont As Long, hOldFont As Long

hFont = CreateFontIndirect(lf)
hOldFont = SelectObject(hPrintDC, hFont)
ret = TextOut(hPrintDC, itsCurrentX, itsCurrentY, strText, LenB(StrConv(strText, vbFromUnicode)))
ret = SelectObject(hPrintDC, hOldFont)
ret = DeleteObject(hFont)

End Sub

Public Sub EndDocs()

If strDOC Then

ret = EndPage(hPrintDC) '结束虚拟打印,temp.prn过渡文件生成完毕
ret = EndDoc(hPrintDC)

'--------------------------------------------
'进入实质打印：

Dim hPrn As Long
Dim Written As Long
Dim I As Long
Dim hFile As Integer
Dim sFile As String
Dim Buffer() As Byte, lstByte As Long
Dim di2 As DOC_INFO_1

hFile = FreeFile
sFile = App.Path & "/" & "temp.prn" '装载过渡文件

di2.pDocName = sFile
di2.pOutputFile = vbNullString
di2.pDatatype = "RAW"

Call OpenPrinter(prnName, hPrn, ByVal 0&)
Call StartDocPrinter(hPrn, 1, di2) '打开一个直传模式的打印Job
Call StartPagePrinter(hPrn)

hFile = FreeFile


Open sFile For Binary Access Read As hFile

If LOF(hFile) > 0 Then
'
ReDim Buffer(1 To LOF(hFile)) As Byte
lstByte = UBound(Buffer) - 3 'temp.prn文件的最后三个字节为翻页指令，此处将此3字节过滤

For I = 1 To lstByte
Get #hFile, , Buffer(I)
Next I

Call WritePrinter(hPrn, Buffer(1), lstByte, Written) '数据直接传送到打印机
End If 'lof=0
Close #hFile

Call EndPagePrinter(hPrn)
DoEvents
Call EndDocPrinter(hPrn) '结束打印
Call ClosePrinter(hPrn)
ret = DeleteDC(hPrintDC)
strDOC = False
Kill sFile '删除过渡文件

End If

End Sub

Public Sub StartDocs()


'创建一个与默认打印机相关联的DC:
hPrintDC = CreateDC("WINSPOOL", prnName, 0, ByVal CLng(0))

di.cbSize = Len(di)
di.lpszDocName = "Heavy Metal Forever" '打印标题，随意设
di.lpszOutput = App.Path & "/" & "temp.prn" '打印到过渡文件
di.lpszDatatype = ""
di.fwType = 0

ret = StartDoc(hPrintDC, di) '以传统模式开始一个打印Job
ret = StartPage(hPrintDC)
strDOC = True

End Sub

Private Sub Class_Initialize()

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))
sRet = UCase(Left(sRet, InStr(sRet, ",") - 1))

prnName = sRet '默认打印机

End Sub

Private Sub Class_Terminate()
'Exit Code
End Sub