用過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: [email protected]
' *************************************************************
' 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