用api调用winspool.drv直接打印时如何设置打印机字体?
如题 --------------------编程问答-------------------- 操作打印机的字体，其实还是GDI函数，即获得打印机DC后，就可以像其它内存绘图DC一样，先用CreateFont创建一个字体对象，然后使用SelectObject把字体对象选入此DC就可以了。不过，由于打印机分辨率与屏幕分辨率不一样，所以，要想达到所见即所得的效果，打印之前还得需要使用SetMapMode、SetWindowExt和SetViewportExt函数转换一下。 --------------------编程问答-------------------- 我在vb中用gdi函数对printer对象的hdc进行操作会直接引起vbide崩溃
(相同代码操作其他dc正常)请问是何原因? --------------------编程问答-------------------- 如是用gdi函数,则不能让打印机即打即停,每次打印都会走一页 --------------------编程问答-------------------- GDI只负责绘制图形和文字，控制打印还得需要winspool.drv。 --------------------编程问答-------------------- 控制打印还得需要winspool.drv,如何既能控制打印又能设置字体呢 --------------------编程问答-------------------- 思路如下：
dim hFont as long
hfont=createfont(...) '创建字体
selectobject(printer.hdc,hfont) '设置字体
drawtext(printer.hdc,..) '绘制文字
printer.enddoc '结束打印（同时把绘制的结果输出到打开机，也可以使用API代替） --------------------编程问答-------------------- 当初用winspool.drv就是为了让打印机不自动走纸,这样打印还是会走纸的,按您的思路就不如直接设置printer.font对象了 --------------------编程问答-------------------- 自己顶一下 --------------------编程问答-------------------- 已经有答案了，还顶啊！ --------------------编程问答-------------------- 答案在哪? --------------------编程问答-------------------- 唉，你问的是如何设置字体啊，告诉你了答案了，又问如何使用API直接打印，这是另外一个问题啊。 --------------------编程问答-------------------- 呵呵,这算两个问题啊,能否一起解决?可以给你双倍的分 --------------------编程问答-------------------- 双倍分也不多啊，代码有点长，我放到博客里了。《VB如何使用API直接操作打印机》 --------------------编程问答-------------------- 顶lyserver --------------------编程问答-------------------- 按lyserver的方法试了,打印机打完之后还是走纸了,没办法控制不走纸
以下是从网上找到的一个不走纸的例子,可惜无法设置字体
--------------------编程问答-------------------- 以下也是从网上找到的一个程序,自己做了一点点修改,基本能完成任务,但是最后一行往往打不出来,诸位高手能否帮忙修改一下
Option Explicit
Private Type DOCINFO
pDocName As String
pOutputFile As String
pDatatype As String
End Type
Private Const LF_FACESIZE = 32
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(LF_FACESIZE) As Byte
End Type
Const DESIREDFONTSIZE = 12 ' Could use variable, TextBox, etc.
Private Const LOGPIXELSY = 90
Private Declare Function ClosePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Function EndDocPrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Function EndPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Function OpenPrinter Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Private Declare Function StartDocPrinter Lib "winspool.drv" Alias "StartDocPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pDocInfo As DOCINFO) As Long
Private Declare Function StartPagePrinter Lib "winspool.drv" (ByVal hPrinter As Long) As Long
Private Declare Function WritePrinter Lib "winspool.drv" (ByVal hPrinter As Long, pbuf As Any, ByVal cdBuf As Long, pcWritten As Long) As Long
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 GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator 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 ' or Boolean
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As Long, ByVal lpInitData As Long) As Long
Private Declare Function DeleteObject Lib "gdi32.dll" (ByVal hObject As Long) As Long
Dim boolFindPrinter As Boolean
Dim lhPrinter As Long
Dim hFont As Long 'Handle to new Font
Private Sub Class_Initialize()
Dim lReturn As Long
Dim lDoc As Long
Dim MyDocInfo As DOCINFO
lReturn = OpenPrinter(Printer.DeviceName, lhPrinter, 0)
If lReturn = 0 Then boolFindPrinter = False Else boolFindPrinter = True
End Sub
Public Property Get FindPrinter() As Boolean
FindPrinter = boolFindPrinter
End Property
Public Sub BegainPrintDoc(ByVal DocName As String)
Dim lReturn As Long
Dim lDoc As Long
Dim MyDocInfo As DOCINFO
MyDocInfo.pDocName = DocName
MyDocInfo.pOutputFile = vbNullString
MyDocInfo.pDatatype = vbNullString
lDoc = StartDocPrinter(lhPrinter, 1, MyDocInfo)
Call StartPagePrinter(lhPrinter)
End Sub
Public Sub PrintStr(ByVal str As String)
Dim lReturn As Long
Dim lpcWritten As Long
lReturn = WritePrinter(lhPrinter, ByVal str, LenB(StrConv(str, vbFromUnicode)), lpcWritten)
End Sub
Public Sub EndPrintDoc()
Dim lReturn As Long
lReturn = EndPagePrinter(lhPrinter)
lReturn = EndDocPrinter(lhPrinter)
'Result = DeleteObject(hFont)
End Sub
Private Sub Class_Terminate()
Dim lReturn As Long
'lReturn = EndPagePrinter(lhPrinter)
'lReturn = EndDocPrinter(lhPrinter)
lReturn = ClosePrinter(lhPrinter)
End Sub
--------------------编程问答-------------------- 唉，真的不知你们怎么搞的，没见我的代码里有一行退纸吗？注释掉不就行了？ --------------------编程问答-------------------- 大哥,您的代码自己试过吗?
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 Const LF_FACESIZE = 32
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
lfFaceName(LF_FACESIZE) As Byte
End Type
Private Const DEFAULT_CHARSET = 1
'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 Declare Function GetDeviceCaps Lib "gdi32" (ByVal hdc As Long, ByVal nIndex As Long) As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Const LOGPIXELSY = 90
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length 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)
Dim vsize As Integer '放大缩小比例
vsize = 1
'lf.lfEscapement = 3150
lf.lfHeight = Abs(MulDiv(CInt(vNewValue * vsize), (GetDeviceCaps(hPrintDC, LOGPIXELSY)), 72))
'lf.lfWidth = 15 'Abs(MulDiv(CInt(vNewValue * vsize * 2 / 3), (GetDeviceCaps(hPrintDC, LOGPIXELSY)), 72))
End Property
Public Property Let fontName(ByVal fName As String)
Dim b() As Byte
lf.lfCharSet = DEFAULT_CHARSET
b = StrConv(fName, vbFromUnicode)
CopyMemory lf.lfFaceName(0), b(0), UBound(b) + 1
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()
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
If strDOC Then
ret = EndPage(hPrintDC) '结束虚拟打印,temp.prn过渡文件生成完毕
ret = EndDoc(hPrintDC)
'--------------------------------------------
'进入实质打印：
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
lstByte = LOF(hFile) - 3 'temp.prn文件的最后三个字节为翻页指令，此处将此3字节过滤
ReDim Buffer(1 To lstByte) As Byte
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 '删除过渡文件
Written = DeleteDC(hPrn) 'Delete the printer device context
'Result = DeleteObject(hFont) 'Delete the font object
End If
End Sub
Public Sub StartDocs()
'创建一个与默认打印机相关联的DC:
hPrintDC = CreateDC("WINSPOOL", prnName, 0, ByVal CLng(0))
di.cbSize = Len(di)
di.lpszDocName = "电机检测" '打印标题，随意设
di.lpszOutput = App.Path & "\" & "temp.prn" '打印到过渡文件
If Dir(di.lpszOutput) <> "" Then Kill di.lpszOutput
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
注释掉依然会退纸!我已经试了N次了 --------------------编程问答-------------------- startpage 和endpage都注释掉也一样 --------------------编程问答-------------------- lyserver大侠,怎么不来了?期待您的帮助! --------------------编程问答-------------------- 不想走纸的话，可以不运行以下语句：
EndPage hPrinterDC
'结束打印
EndDoc hPrinterDC
'还原打印机DC中的字体
SelectObject hPrinterDC, hOldFont
'删除创建的字体
DeleteObject hFont
'删除打印机DC
DeleteDC hPrinterDC
这样，因为打印机一直处于打印状态，故不会自动走纸。 --------------------编程问答-------------------- 还是有问题,不执行EndDoc打印机是不会马上打印的 --------------------编程问答-------------------- lyserver???
补充：VB , 基础类
