虎门有什么山可以爬:VB打印如何设置页面属性

Windows默认都是按照"页"来处理打印的, 这在打印一些票据,特别是流水作业的时候非常恼火, 我也曾经对此头疼过, 后来我自己写了一个类模块解决了这个问题, 通过这个模块, 你可以让打印机按"行"来打印,即做到打印机仅打印一行,然后并不执行退纸动作,然后接到下一个打印命令的时候再打一行,如此反复, 但我这个模块只能在针式打印机上实现,在喷墨和激光打印机上依然还是按"页"打印, 代码如下:

' ****************************************
' LBL (Line By Line) Print class
' 2004.06.01 Written By Rockage(Yang Hua)
' http://www.stoneren.com
' email: rockages@gmail.com
' 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

本人QQ122590,如有疑问可联系,大家一起交流!!

参考以下网址,应该满足你的要求
http://host.bluexp.net/vbgood/experience/index.asp?action=read&id=1481
http://host.bluexp.net/vbgood/experience/index.asp?action=read&id=1482
http://host.bluexp.net/vbgood/experience/index.asp?action=read&id=2683