'******************************重要：VB6 form 的 AutoRedraw 属性变动后，hDc是不一样的，true 和 false 分别对应一个DC
'+------------------------------------------------------------+
'|功能：一个使用自定义尺寸纸型，定位打印的类 |
'|描述：API实现自定义尺寸纸张打印与模拟显示 |
'|日期：2023-08-19 7:30 |
'|编者：天下乌贼 |
'|关注：https://wjjhyf.eu5.org |
'+------------------------------------------------------------+
'-----------------------------------------------------------------------------------------------+
'以下是新手使用，PrinterBegin打开打印机，PrinterTextOut打印，PrinterEnd关闭打印机，打印机输出 |
'所有X，Y坐标均为毫米，精确到0.1毫米,字体大小为磅，与word、execl等一致且设备无关 |
'区别： |
'TextOut--在指定坐标打印 |
'ExtTextOut--在指定坐标打印，可以指定字间距【打印固定格式的邮编用】 |
'DrawText--在指定区域打印，可以自动换行、对齐、居中 |
'以上三个函数效率从高到低 |
'-----------------------------------------------------------------------------------------------+
'------------------------函数列表----------------------------------
'imgHandl2StdPicture -将image句柄转换成IPictureDisp对象
'PtrCtoVbString -将字符串地址转换成VB字符串
'DrawBox -画一个矩形
'CreateFontIndirect -根据单元设置字体, 返回创建字体的handle
'CreateFont -根据参数设置字体, 返回创建字体的handle
'SetTextColor -设置打印字体颜色
'GetTextColor -取打印字体颜色
'SetFont -设置字体
'SetFontIndirect -根据单元设置字体
'CalcStrRect -计算印字符串需要的矩形大小
'TextOut -打印字符串
'ExtTextOut -打印字符串
'DrawText -打印字符串
'BitBlt -打印图像
'OpenPrinter -打开打印机
'ClosePrinte -关闭已打开打印机
'EnumPrinters -返回打印机的所有名称
'GetPrinterInfo -取打印机信息
'EnumForms -列举所有打印机支持的纸张
'AddForm -为打印机添加纸张
'DeleteForm -删除自定义纸张
'FormDefault -取打印机的默认页形
'FormSize -取打印机的页形的尺寸
'GetPrinterDriver -取打印机驱动
'PrinterEnd-结束打印，释放资源
'PrinterStart-启动打印机设备，返回打印DC，直接操作DC
'SetMode -设置打印的镜像方向
'NewPage结束当前页打印，开始新的一页
'------------------------函数列表结束--------------------------------
'--------------------------------------------------------------------
'功能：取打印机Handle
'入口：无
'出口：打印机Handle
'--------------------------------------------------------------------
'Public Property Get PrinterHandle() As Long
'--------------------------------------------------------------------
'功能：取打印机DC
'入口：无
'出口：打印机DC
'--------------------------------------------------------------------
'Public Property Get hDc() As Long
'-------------------------------------------------------------
'功能： 画一个矩形
'-------------------------------------------------------------
'Public Sub DrawBox(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, _
' Optional ByVal iLineWidth As Long = 1, Optional ByVal iColor As Long)
'-------------------------------------------------------------
'功能：设置打印字体颜色
'入口：无
'出口：无
'-------------------------------------------------------------
'Public Function SetTextColor(ByVal iColor As Long) As Long
'-------------------------------------------------------------
'功能：取打印字体颜色
'入口：无
'出口：颜色
'-------------------------------------------------------------
'Public Function GetTextColor() As Long
'-------------------------------------------------------------
'功能： 设置字体
'-------------------------------------------------------------
'Public Function SetFont(Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, _
' Optional bFontStrikethrough) As Long
'-------------------------------------------------------------
'功能： 根据单元设置字体
'-------------------------------------------------------------
'Public Function SetFontIndirect(oFont As StdFont) As Long
'功能：取打印字符串需要的矩形大小
'Public Function CalcStrRect(ByVal sText As String, _
' Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, _
' Optional bFontUnderline, Optional bFontStrikethrough) As String
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
'Public Function TextOut(ByVal dblX As Double, ByVal dblY As Double, ByVal sText As String, Optional iTextColor, _
' Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, Optional bFontStrikethrough) As Long
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
'Public Function ExtTextOut(ByVal dblX As Double, ByVal dblY As Double, ByVal sText As String, Optional ByVal dblDx As Double, Optional iTextColor, _
' Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, Optional bFontStrikethrough) As Long
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
'Public Function DrawText(ByVal dblLeft As Double, ByVal dblTop As Double, ByVal dblRight As Double, ByVal dblBottom As Double, _
' ByVal sText As String, ByVal iFormat As TextDrawFMT, Optional iTextColor, _
' Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, _
' Optional bFontUnderline, Optional bFontStrikethrough) As Long
'-------------------------------------------------------------
'功能：打印图像 dRatio倍率
'-------------------------------------------------------------
'Public Function BitBlt(lImagHandle As Long, Optional dRatio As Single, Optional dX As Single, Optional dY As Single, Optional dW As Single, Optional dH As Single, _
' Optional sX As Single, Optional sY As Single, Optional sW As Single, Optional sH As Single) As Long
'--------------------------------------------------------------------
'功能：返回打印机的所有名称
'入口：
'出口：打印机的所有名称,用vbCrLf分隔
'--------------------------------------------------------------------
'Public Function EnumPrinters() As String
'--------------------------------------------------------------------
'功能：取打印机信息
'入口：要打印机handle
'出口：打印机信息，以vbcrlf分隔 flags，pName，pDescription，pComment
'--------------------------------------------------------------------
'Public Function GetPrinterInfo(Optional hPrintHandle As Long) As String
'--------------------------------------------------------------------
'功能：列举所有打印机支持的纸张
'入口：打印机handle
'出口：所有纸形，用vbcrlf分隔，各纸形参数用vbtab分隔
'--------------------------------------------------------------------
'Public Function EnumForms(Optional hPrintHandle As Long) As String
'--------------------------------------------------------------------
'功能：为打印机添加纸张
'入口：要打印机handle、名称、宽度、长度（单位：千分之一毫米）
'出口：true-成功
'--------------------------------------------------------------------
'Public Function AddForm(pName As String, cx As Long, cy As Long, Optional hPrintHandle As Long) As Boolean
'--------------------------------------------------------------------
'功能：删除自定义纸张
'入口：要打印机handle、名称
'出口：true-成功
'--------------------------------------------------------------------
'Public Function DeleteForm(pName As String, Optional hPrintHandle As Long) As Boolean
'--------------------------------------------------------------------
'功能：取打印机的默认页形
'入口：要打印机handle
'出口：默认页形
'--------------------------------------------------------------------
'Public Function FormDefault(Optional hPrintHandle As Long) As String
'--------------------------------------------------------------------
'功能：取打印机的页形的尺寸
'入口：要打印机handle，页形名称
'出口：页形的尺寸 以vbcrlf分隔
'--------------------------------------------------------------------
'Public Function FormSize(Optional ByVal sFormName As String, Optional hPrintHandle As Long) As String
'--------------------------------------------------------------------
'功能：取打印机驱动
'入口：要打印机handle
'出口：打印机驱动名
'--------------------------------------------------------------------
'Public Function GetPrinterDriver(Optional hPrintHandle As Long) As String
'-------------------------------------------------------------
'功能：结束打印，释放资源
'入口：无
'出口：如果模拟显示，返回一个标准StdPicture
'-------------------------------------------------------------
'Public Function PrinterEnd() As StdPicture
'-----------------------------------------------------------------------------------------------------+
'功能：启动打印机设备，返回打印DC，直接操作DC |
'入口：sDeviceName 设备名称（DISPLAY-屏幕,其它为打印机名称，如果打印机名不存在，为默认打印机） |
' iPageWidth 纸面宽度, iPageHeight 纸面高度 （为零时，由纸张名称取长、宽,单位毫米） |
' sFormName 纸张名称，为空取默认, iOrientation 纸张放置方向 vbPRORPortrait, bReverse:反向打印 |
'出口：打印机DC |
'不用设置纸形，直接设置DC，兼容性强 |
'-----------------------------------------------------------------------------------------------------+
'Public Function PrinterStart(Optional ByVal sPrinterName As String, Optional ByVal sFormName As String, _
' Optional ByVal iOrientation As PrinterObjectConstants = 0, _
' Optional ByVal dblPageWidth As Single, Optional ByVal dblPageHeight As Single, Optional bReverse As Boolean) As Long
'-----------------------------------------------------------------------------------------------------+
'功能：设置打印的镜像方向 |
'入口：镜像方向 |
'出口：无 |
'-----------------------------------------------------------------------------------------------------+
'Public Sub SetMode(iMd As MIRRORDIRECTION)
'-------------------------------------------------------------
'功能：结束当前页打印，开始新的一页
'入口：无
'出口：无
'-------------------------------------------------------------
'Public Sub PrinterNewPage()
Option Explicit
Private Const HORZSIZE = 4 ' Horizontal size in millimeters
Private Const VERTSIZE = 6 ' Vertical size in millimeters
Private Const LOGPIXELSX = 88 ' Logical pixels/inch in X
Private Const LOGPIXELSY = 90 ' Logical pixels/inch in Y
Private Const SYSTEM_FONT = 13
Private Const WHITE_BRUSH = 0
Private Type POINTAPI
x As Long
y As Long
End Type
Private Type SIZE
cx As Long
cy As Long
End Type
Private Type RECT
Left As Long
Top As Long
Right As Long
Bottom As Long
End Type
Private Type GUID
Data1 As Long
Data2 As Integer
Data3 As Integer
Data4(7) As Byte
End Type
Private Declare Function CLSIDFromStringAPI Lib "ole32.dll" Alias "CLSIDFromString" (ByVal lpsz As Long, ByRef pclsid As GUID) As Long
Private Declare Function GetLastError Lib "kernel32" () As Long
Private Declare Function GetDesktopWindow Lib "user32" () As Long
Private Declare Function MulDiv Lib "kernel32" (ByVal nNumber As Long, ByVal nNumerator As Long, ByVal nDenominator As Long) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Sub ZeroMemory Lib "kernel32" Alias "RtlZeroMemory" (Destination As Any, ByVal Length As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Long) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString1 As Long) As Long
Private Declare Function lstrcpyW Lib "kernel32" (ByVal lpString1 As String, ByVal lpString2 As String) As Long
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString1 As String) As Long
'--------------将句柄包装成对象---------------------------
Private Const PICTYPE_BITMAP = 1
Private Type PICTDESC
cbSize As Long
picType As Long
hPic As Long
hPal As Long
End Type
Private Declare Function OleCreatePictureIndirect Lib "olepro32.dll" (picDesc As PICTDESC, RefIID As GUID, ByVal fOwn As Long, iPic As IPictureDisp) As Long
'--------------DC---------------------------
Private Const CLEARTYPE_QUALITY As Long = 5
Private Const LF_FACESIZE = 32
Private Const DT_TOP = &H0
Private Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_RIGHT = &H2
Private Const DT_VCENTER = &H4
Private Const DT_BOTTOM = &H8
Private Const DT_WORDBREAK = &H10
Private Const DT_SINGLELINE = &H20
Private Const DT_EXPANDTABS = &H40
Private Const DT_TABSTOP = &H80
Private Const DT_NOCLIP = &H100
Private Const DT_EXTERNALLEADING = &H200
Private Const DT_CALCRECT = &H400
Private Const DT_NOPREFIX = &H800
Private Const DT_INTERNAL = &H1000
Private Const DT_EDITCONTROL = &H2000
Private Const DT_PATH_ELLIPSIS = &H4000
Private Const DT_END_ELLIPSIS = &H8000
Private Const DT_MODIFYSTRING = &H10000
Private Const DT_RTLREADING = &H20000
Private Const DT_WORD_ELLIPSIS = &H40000
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(1 To LF_FACESIZE) As Byte
End Type
Private Type DRAWTEXTPARAMS
cbSize As Long
iTabLength As Long
iLeftMargin As Long
iRightMargin As Long
uiLengthDrawn As Long
End Type
Private Type PAINTSTRUCT
hDc As Long
fErase As Long
rcPaint As RECT
fRestore As Long
fIncUpdate As Long
rgbReserved(32) As Byte
End Type
Private Declare Function CreateDC Lib "gdi32" Alias "CreateDCA" (ByVal lpDriverName As String, ByVal lpDeviceName As String, ByVal lpOutput As String, lpInitData As Any) As Long 'DEVMODE
Private Declare Function CreateCompatibleDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function CreateCompatibleBitmap Lib "gdi32" (ByVal hDc As Long, ByVal nWidth As Long, ByVal nHeight As Long) As Long
Private Declare Function CreateBitmap Lib "gdi32" (ByVal nWidth As Long, ByVal nHeight As Long, ByVal nPlanes As Long, ByVal nBitCount As Long, lpBits As Any) As Long
Private Declare Function DeleteDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function GetDCEx Lib "user32" (ByVal hwnd As Long, ByVal hrgnclip As Long, ByVal fdwOptions As Long) As Long
Private Declare Function GetDC Lib "user32" (ByVal hwnd As Long) As Long
Private Declare Function SaveDC Lib "gdi32" (ByVal hDc As Long) As Long
Private Declare Function RestoreDC Lib "gdi32" (ByVal hDc As Long, ByVal nSavedDC As Long) As Long
Private Declare Function ResetDC Lib "gdi32" Alias "ResetDCA" (ByVal hDc As Long, lpInitData As Any) As Long
Private Declare Function TextOutAPI 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 CreateFontIndirectAPI Lib "gdi32" Alias "CreateFontIndirectA" (lpLogFont As LOGFONT) As Long
Private Declare Function GetStockObject Lib "gdi32" (ByVal nIndex As Long) As Long
Private Declare Function SelectObject Lib "gdi32" (ByVal hDc As Long, ByVal hObject As Long) As Long
Private Declare Function DeleteObject Lib "gdi32" (ByVal hObject As Long) As Long
Private Declare Function CloseHandle Lib "kernel32" (ByVal hObject As Long) As Long
Private Declare Function SetMapMode Lib "gdi32" (ByVal hDc As Long, ByVal nMapMode As Long) As Long
Private Declare Function GetDeviceCaps Lib "gdi32" (ByVal hDc As Long, ByVal nIndex As Long) As Long
Private Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
Private Declare Function SetViewportExtEx Lib "gdi32" (ByVal hDc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Any) As Long
Private Declare Function SetViewportOrgEx Lib "gdi32" (ByVal hDc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As Any) As Long
Private Declare Function SetWindowExtEx Lib "gdi32" (ByVal hDc As Long, ByVal nX As Long, ByVal nY As Long, lpSize As Any) As Long
Private Declare Function SetWindowOrgEx Lib "gdi32" (ByVal hDc As Long, ByVal nX As Long, ByVal nY As Long, lpPoint As Any) As Long
Private Declare Function FillRect Lib "user32" (ByVal hDc As Long, lpRect As RECT, ByVal hBrush As Long) As Long
Private Declare Function DrawTextAPI Lib "user32" Alias "DrawTextA" (ByVal hDc As Long, ByVal lpStr As String, ByVal nCount As Long, lpRect As RECT, ByVal wFormat As Long) As Long
Private Declare Function DrawTextExAPI Lib "user32" Alias "DrawTextExA" (ByVal hDc As Long, ByVal lpsz As String, ByVal n As Long, lpRect As RECT, ByVal un As Long, lpDrawTextParams As DRAWTEXTPARAMS) As Long
Private Declare Function ExtTextOutAPI Lib "gdi32" Alias "ExtTextOutA" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long, ByVal wOptions As Long, lpRect As Any, ByVal lpString As String, ByVal nCount As Long, lpDx As Any) As Long
Private Declare Function LineTo Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long) As Long
Private Declare Function MoveToEx Lib "gdi32" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long, lpPoint As Any) As Long
Private Const PS_SOLID = 0
Private Const PS_DASH = 1 ' -------
Private Const PS_DOT = 2 ' .......
Private Const PS_DASHDOT = 3 ' _._._._
Private Const PS_DASHDOTDOT = 4 ' _.._.._
Private Const PS_NULL = 5
Private Declare Function CreatePen Lib "gdi32" (ByVal nPenStyle As Long, ByVal nWidth As Long, ByVal crColor As Long) As Long
Private Const GM_ADVANCED = 2
Private Const GM_COMPATIBLE = 1
Private Declare Function SetGraphicsMode Lib "gdi32" (ByVal hDc As Long, ByVal iMode As Long) As Long
'设置高级图形模式
Private Type XFORM 'API Load 定义错误
eM11 As Single
eM12 As Single
eM21 As Single
eM22 As Single
eDx As Single
eDy As Single
End Type
Private Declare Function SetWorldTransform Lib "gdi32" (ByVal hDc As Long, lpXform As Any) As Long 'XFORM
Private Declare Function SetTextColorAPI Lib "gdi32" Alias "SetTextColor" (ByVal hDc As Long, ByVal crColor As Long) As Long
Private Declare Function GetTextColorAPI Lib "gdi32" Alias "GetTextColor" (ByVal hDc As Long) As Long
Private Const R2_MERGEPEN = 15 ' DPo
Private Declare Function SetROP2 Lib "gdi32" (ByVal hDc As Long, ByVal nDrawMode As Long) As Long
Private Declare Function GetROP2 Lib "gdi32" (ByVal hDc As Long) As Long
Private Const TRANSPARENT = 1
Private Const MM_LOMETRIC = 2
Private Declare Function SetBkMode Lib "gdi32" (ByVal hDc As Long, ByVal nBkMode As Long) As Long
Private Type BITMAP
bmType As Long
bmWidth As Long
bmHeight As Long
bmWidthBytes As Long
bmPlanes As Long
bmBitsPixel As Long
bmBits As Long
End Type
Private Declare Function GetObject Lib "gdi32" Alias "GetObjectA" (ByVal hObject As Long, ByVal nCount As Long, lpObject As Any) As Long
Private Const SRCCOPY = &HCC0020 ' (DWORD) dest = source
Private Declare Function BitBltAPI Lib "gdi32" Alias "BitBlt" (ByVal hDestDC As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal dwRop As Long) As Long
Private Declare Function StretchBltAPI Lib "gdi32" Alias "StretchBlt" (ByVal hDc As Long, ByVal x As Long, ByVal y As Long, ByVal nWidth As Long, ByVal nHeight As Long, ByVal hSrcDC As Long, ByVal xSrc As Long, ByVal ySrc As Long, ByVal nSrcWidth As Long, ByVal nSrcHeight As Long, ByVal dwRop As Long) As Long
Private Declare Function GetBitmapBits Lib "gdi32" (ByVal hBitmap As Long, ByVal dwCount As Long, lpBits As Any) As Long
'--------------printer---------------------------
Private Const DM_PAPERSIZE = &H2&
Private Const DM_PAPERWIDTH = &H8&
Private Const DM_PAPERLENGTH = &H4&
Private Const DM_COPY = 2
Private Const DM_PROMPT = 4
Private Const DM_MODIFY = 8
Private Const DM_PrintQuality = &H400
Private Const DM_IN_PROMPT = DM_PROMPT
Private Const DM_IN_BUFFER = DM_MODIFY
Private Const DM_OUT_BUFFER = DM_COPY
Private Const DM_FORMNAME As Long = &H10000
Private Const DMORIENT_PORTRAIT = 1
Private Const DMORIENT_LANDSCAPE = 2
Private Const DM_ORIENTATION = &H1&
Private Const PRINTER_ENUM_NAME = &H8
Private Const MM_LOENGLISH = 4
Private Const MM_ISOTROPIC As Long = 7
Private Const MM_ANISOTROPIC = 8
Private Const CCHDEVICENAME = 32
Private Const CCHFORMNAME = 32
Private Type DOCINFO
cbSize As Long
lpszDocName As String
lpszOutput As String
End Type
Private Type DEVMODE
dmDeviceName As String * CCHDEVICENAME
dmSpecVersion As Integer
dmDriverVersion As Integer
dmSize As Integer
dmDriverExtra As Integer
dmFields As Long
dmOrientation As Integer
dmPaperSize As Integer
dmPaperLength As Integer
dmPaperWidth As Integer
dmScale As Integer
dmCopies As Integer
dmDefaultSource As Integer
dmPrintQuality As Integer
dmColor As Integer
dmDuplex As Integer
dmYResolution As Integer
dmTTOption As Integer
dmCollate As Integer
dmFormName As String * CCHFORMNAME
dmUnusedPadding As Integer
dmBitsPerPel As Long
dmPelsWidth As Long
dmPelsHeight As Long
dmDisplayFlags As Long
dmDisplayFrequency As Long
End Type
Private Declare Function OpenPrinterAPI Lib "winspool.drv" Alias "OpenPrinterA" (ByVal pPrinterName As String, phPrinter As Long, ByVal pDefault As Long) As Long
Private Declare Function GetDefaultPrinterAPI Lib "winspool.drv" Alias "GetDefaultPrinterA" (ByVal szPrinter As String, bufferSize As Long) As Long
Private Declare Function ClosePrinterAPI Lib "winspool.drv" Alias "ClosePrinter" (ByVal hPrinter As Long) As Long
Private Declare Function DocumentProperties Lib "winspool.drv" Alias "DocumentPropertiesA" (ByVal hwnd As Long, ByVal hPrinter As Long, ByVal pDeviceName As String, pDevModeOutput As Any, pDevModeInput As Any, ByVal fMode As Long) As Long
Private Declare Function StartDocAPI Lib "gdi32" Alias "StartDocA" (ByVal hDc As Long, lpdi As DOCINFO) As Long
Private Declare Function EndDocAPI Lib "gdi32" Alias "EndDoc" (ByVal hDc As Long) As Long
Private Declare Function StartPageAPI Lib "gdi32" Alias "StartPage" (ByVal hDc As Long) As Long
Private Declare Function EndPageAPI Lib "gdi32" Alias "EndPage" (ByVal hDc As Long) As Long
Private Type PRINTER_INFO_1 '不加S是取值时用
flags As Long
pDescription As Long ' String
pName As Long ' String
pComment As Long ' String
End Type
Private Type PRINTER_INFO_5 '不加S是取值时用
pPrinterName As Long
pPortName As Long
Attributes As Long
DeviceNotSelectedTimeout As Long
TransmissionRetryTimeout As Long
End Type
Private Declare Function EnumPrintersAPI Lib "winspool.drv" Alias "EnumPrintersA" (ByVal flags As Long, ByVal name As String, ByVal Level As Long, pPrinterEnum As Byte, ByVal cdBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function GetPrinterDriverAPI Lib "winspool.drv" Alias "GetPrinterDriverA" (ByVal hPrinter As Long, ByVal pEnvironment As String, ByVal Level As Long, pDriverInfo As Byte, ByVal cdBuf As Long, pcbNeeded As Long) As Long
Private Type FORM_INFO_1
flags As Long
pName As Long ' String
SIZE As SIZE
ImageableArea As RECT
End Type
Private Type FORM_INFO_1_S
flags As Long
pName As String ' String
SIZE As SIZE
ImageableArea As RECT
End Type
Private Declare Function EnumFormsAPI Lib "winspool.drv" Alias "EnumFormsA" (ByVal hPrinter As Long, ByVal Level As Long, pForm As Byte, ByVal cbBuf As Long, pcbNeeded As Long, pcReturned As Long) As Long
Private Declare Function DeleteFormAPI Lib "winspool.drv" Alias "DeleteFormA" (ByVal hPrinter As Long, ByVal pFormName As String) As Long
Private Declare Function AddFormAPI Lib "winspool.drv" Alias "AddFormA" (ByVal hPrinter As Long, ByVal Level As Long, pForm As Byte) As Long
Private Declare Function GetFormAPI Lib "winspool.drv" Alias "GetFormA" (ByVal hPrinter As Long, ByVal pFormName As String, ByVal Level As Long, pForm As Byte, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Private Type PRINTER_INFO_2
pServerName As Long
pPrinterName As Long
pShareName As Long
pPortName As Long
pDriverName As Long
pComment As Long
pLocation As Long
pDevMode As Long
pSepFile As Long
pPrintProcessor As Long
pDatatype As Long
pParameters As Long
pSecurityDescriptor As Long
Attributes As Long
Priority As Long
DefaultPriority As Long
StartTime As Long
UntilTime As Long
Status As Long
cJobs As Long
AveragePPM As Long
End Type
Private Declare Function GetPrinterAPI Lib "winspool.drv" Alias "GetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Any, ByVal cbBuf As Long, pcbNeeded As Long) As Long
Private Declare Function SetPrinterAPI Lib "winspool.drv" Alias "SetPrinterA" (ByVal hPrinter As Long, ByVal Level As Long, pPrinter As Byte, ByVal Command As Long) As Long
'--------------this---------------------------
'Public Type SIZE_PAGE
' Width As Long
' Height As Long
'End Type
Public Enum MIRRORDIRECTION '打印镜像方向
MD_NORMAL '正常
MD_LEFT2RIGHT '上下印镜像
MD_UP2DOWN '上下印镜像
MD_LEFTTOP2RIGHTBOTTOM '180度
End Enum
Public Enum TextDrawFMT
FMT_TOP = &H0
FMT_LEFT = &H0
FMT_CENTER = &H1
FMT_RIGHT = &H2
FMT_VCENTER = &H4
FMT_BOTTOM = &H8
FMT_WORDBREAK = &H10
FMT_SINGLELINE = &H20
FMT_EXPANDTABS = &H40
FMT_TABSTOP = &H80
FMT_NOCLIP = &H100
FMT_EXTERNALLEADING = &H200
FMT_CALCRECT = &H400
FMT_NOPREFIX = &H800
FMT_INTERNAL = &H1000
FMT_MODIFYSTRING = &H10000
FMT_EDITCONTROL = &H2000
FMT_HIDEPREFIX = &H100000
End Enum
'VBA没有PrinterObjectConstants
Public Enum PrinterObjectConstants
vbPRORLandscape = &H2&
vbPRORPortrait = &H1&
End Enum
Private lPrinterHandle As Long '打印机handle
Private lPrinterDC As Long '打印机DC
Private lPictureHandle As Long '模拟显示之图像handle
Private lPictureDC As Long '模拟显示之图像DC
Private isPrinter As Boolean 'true,打印机输出
'--------------------------------------------------------------------
'功能：取打印机DC
'入口：无
'出口：打印机DC
'--------------------------------------------------------------------
Public Property Get PrinterHandle() As Long
PrinterHandle = lPrinterHandle
End Property
'--------------
'--------------------------------------------------------------------
'功能：取打印机DC
'入口：无
'出口：打印机DC
'--------------------------------------------------------------------
Public Property Get hDc() As Long
hDc = lPrinterDC
End Property
'--------------------------------------------------------------------
'功能：设置打印机DC，调试用,正常不能使用
'入口：无
'出口：打印机DC
'--------------------------------------------------------------------
'Public Property Let hDc(ByVal hDc As Long)
' lPrinterDC = hDc
'End Property
Private Sub Class_Initialize()
'什么也不做
End Sub
Private Sub Class_Terminate()
'什么清理资源
Call PrinterEnd
End Sub
'--------------------------------------------------------------------
'功能：将image句柄转换成IPictureDisp对象，句柄不能释放 bCopySouce将数据备份，就不丢图像
'入口：字符串地址
'出口：VB字符串
'技巧：数据直接复制
' Dim bData() As Byte, bm As BITMAP
' ReDim bData(bm.bmWidthBytes * bm.bmHeight)
' Call GetBitmapBits(lHandle, bm.bmWidthBytes * bm.bmHeight, bData(0))
' lHandle = CreateBitmap(bm.bmWidth, bm.bmHeight, bm.bmPlanes, bm.bmBitsPixel, bData(0))
' Erase bData
'--------------------------------------------------------------------
Private Function imgHandl2StdPicture(ByVal lHandle As Long, Optional bCopySouce As Boolean) As IPictureDisp
Dim IID_IDispatch As GUID
Dim picDesc As PICTDESC, bm As BITMAP
Dim hDestDC As Long, hSrcDC As Long, hSrcPic As Long, hPicOld As Long
If lHandle = 0 Then Exit Function
If bCopySouce Then
Call GetObject(lHandle, LenB(bm), bm)
hSrcDC = CreateCompatibleDC(lPrinterDC)
hPicOld = SelectObject(hSrcDC, lHandle)
hDestDC = CreateCompatibleDC(lPrinterDC)
lHandle = CreateCompatibleBitmap(hSrcDC, bm.bmWidth, bm.bmHeight)
Call SelectObject(hDestDC, lHandle)
Call BitBltAPI(hDestDC, 0, 0, bm.bmWidth, bm.bmHeight, hSrcDC, 0, 0, SRCCOPY)
Call SelectObject(hSrcDC, hPicOld)
Call DeleteDC(hDestDC)
Call DeleteDC(hSrcDC)
End If
' 创建临时图像对象
Call CLSIDFromStringAPI(StrPtr("{00020400-0000-0000-C000-000000000046}"), IID_IDispatch)
With picDesc
.cbSize = Len(picDesc)
.picType = PICTYPE_BITMAP
.hPic = lHandle
End With
OleCreatePictureIndirect picDesc, IID_IDispatch, 1, imgHandl2StdPicture
End Function
'--------------------------------------------------------------------
'功能：将字符串地址转换成VB字符串
'入口：字符串地址
'出口：VB字符串
'--------------------------------------------------------------------
Private Function PtrCtoVbString(ByVal lngStrAddr As Long) As String
Dim iLen As Long
iLen = lstrlen(lngStrAddr)
If iLen = 0 Then Exit Function
PtrCtoVbString = String(iLen, vbNullChar)
Call lstrcpy(PtrCtoVbString, ByVal lngStrAddr)
End Function
'-------------------------------------------------------------
'功能： 画一个矩形
'-------------------------------------------------------------
Public Sub DrawBox(ByVal x1 As Double, ByVal y1 As Double, ByVal x2 As Double, ByVal y2 As Double, _
Optional ByVal iLineWidth As Long = 1, Optional ByVal iColor As Long)
Dim iPen As Long, iOldPen As Long
If lPrinterDC = 0 Then
Exit Sub
End If
iPen = CreatePen(PS_SOLID, iLineWidth, iColor)
iOldPen = SelectObject(lPrinterDC, iPen)
Call MoveToEx(lPrinterDC, x1, y1, ByVal 0)
Call LineTo(lPrinterDC, x2, y1)
Call LineTo(lPrinterDC, x2, y2)
Call LineTo(lPrinterDC, x1, y2)
Call LineTo(lPrinterDC, x1, y1)
Call SelectObject(lPrinterDC, iOldPen)
Call DeleteObject(iPen)
End Sub
'-------------------------------------------------------------
'功能： 根据单元设置字体,返回创建字体的handle
'-------------------------------------------------------------
Private Function CreateFontIndirect(oFont As StdFont, Optional lEscapement As Long) As Long
Dim fontPrinter As LOGFONT
Dim aFontName() As Byte
Call ZeroMemory(fontPrinter, Len(fontPrinter))
With fontPrinter
'.lfHeight = -MulDiv(oFont.SIZE, GetDeviceCaps(lPrinterDC, LOGPIXELSY), 72) '0 / 72 '显示器是96，打印机是100 = ;
.lfHeight = oFont.SIZE * 254 / 72
.lfItalic = oFont.Italic
.lfWeight = IIf(oFont.Bold, 700, 400)
.lfUnderline = oFont.Underline
.lfStrikeOut = oFont.Strikethrough
.lfCharSet = 134 'GB2312_CHARSET
.lfQuality = CLEARTYPE_QUALITY
.lfEscapement = lEscapement '-1800
.lfOrientation = lEscapement
End With
aFontName = StrConv(oFont.name + vbNullChar, vbFromUnicode)
CopyMemory fontPrinter.lfFaceName(1), aFontName(0), UBound(aFontName) + 2
CreateFontIndirect = CreateFontIndirectAPI(fontPrinter)
End Function
'-------------------------------------------------------------
'功能： 根据单元设置字体,返回创建字体的handle
'-------------------------------------------------------------
Private Function CreateFont(Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, _
Optional bFontStrikethrough) As Long
Dim oFont As New StdFont
If IsMissing(iFontSize) And IsMissing(sFontName) And IsMissing(bFontBold) _
And IsMissing(bFontItalic) And IsMissing(bFontUnderline) Then
'全为则恢复系统默认字体
CreateFont = GetStockObject(SYSTEM_FONT)
Else
With oFont
.SIZE = IIf(Not IsMissing(iFontSize) And IsNumeric(iFontSize), Val("0" & iFontSize), .SIZE)
.name = IIf(IsMissing(sFontName), .name, sFontName)
.Bold = IIf(IsMissing(bFontBold), .Bold, CBool(bFontBold))
.Italic = IIf(IsMissing(bFontItalic), .Italic, CBool(bFontItalic))
.Underline = IIf(IsMissing(bFontUnderline), .Underline, CBool(bFontUnderline))
.Strikethrough = IIf(IsMissing(bFontStrikethrough), .Strikethrough, CBool(bFontStrikethrough))
End With
CreateFont = CreateFontIndirect(oFont)
End If
End Function
'-------------------------------------------------------------
'功能：设置打印字体颜色
'入口：无
'出口：无
'-------------------------------------------------------------
Public Function SetTextColor(ByVal iColor As Long) As Long
SetTextColor = SetTextColorAPI(lPrinterDC, iColor)
End Function
'-------------------------------------------------------------
'功能：取打印字体颜色
'入口：无
'出口：颜色
'-------------------------------------------------------------
Public Function GetTextColor() As Long
GetTextColor = GetTextColorAPI(lPrinterDC)
End Function
'-------------------------------------------------------------
'功能： 设置字体
'-------------------------------------------------------------
Public Function SetFont(Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, _
Optional bFontStrikethrough) As Long
Dim iFont As Long, oFont As New StdFont
'用系统默认字体替换lPrinterDC字体，然后释放它，防止内存世露
iFont = GetStockObject(SYSTEM_FONT)
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
SetFont = CreateFont(iFontSize, sFontName, bFontBold, bFontItalic, bFontUnderline, bFontStrikethrough)
'已恢复默认系统字体，不用DeleteObject
Call SelectObject(lPrinterDC, SetFont)
End Function
'-------------------------------------------------------------
'功能： 根据单元设置字体
'-------------------------------------------------------------
Public Function SetFontIndirect(oFont As StdFont) As Long
Dim iFont As Long
'用系统默认字体替换lPrinterDC字体，然后释放它，防止内存世露
iFont = GetStockObject(SYSTEM_FONT)
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
SetFontIndirect = CreateFontIndirect(oFont)
'已恢复默认系统字体，不用DeleteObject
Call SelectObject(lPrinterDC, SetFontIndirect)
End Function
'功能：取打印字符串需要的矩形大小
Public Function CalcStrRect(ByVal sText As String, _
Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, _
Optional bFontUnderline, Optional bFontStrikethrough) As String
Dim rtRect As RECT
Dim iFont As Long
If sText = "" Then
Exit Function
End If
If Not (IsMissing(iFontSize) And IsMissing(sFontName) And IsMissing(bFontBold) _
And IsMissing(bFontItalic) And IsMissing(bFontUnderline) And IsMissing(bFontStrikethrough)) Then
iFont = CreateFont(iFontSize, sFontName, bFontBold, bFontItalic, bFontUnderline, bFontStrikethrough)
iFont = SelectObject(lPrinterDC, iFont)
End If
Call DrawTextAPI(lPrinterDC, sText, LenB(StrConv(sText, vbFromUnicode)), rtRect, DT_CALCRECT)
With rtRect
CalcStrRect = .Right & vbTab & .Bottom
End With
If Not iFont = 0 Then
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
End If
End Function
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
Public Function TextOut(ByVal dblX As Double, ByVal dblY As Double, ByVal sText As String, Optional iTextColor, _
Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, Optional bFontStrikethrough) As Long
Dim oFont As New StdFont
Dim iFont As Long
If dblX < 0 Or dblY < 0 Or sText = "" Then
Exit Function
End If
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not (IsMissing(iFontSize) And IsMissing(sFontName) And IsMissing(bFontBold) _
And IsMissing(bFontItalic) And IsMissing(bFontUnderline) And IsMissing(bFontStrikethrough)) Then
iFont = CreateFont(iFontSize, sFontName, bFontBold, bFontItalic, bFontUnderline, bFontStrikethrough)
iFont = SelectObject(lPrinterDC, iFont)
End If
TextOut = TextOutAPI(lPrinterDC, dblX, dblY, sText, LenB(StrConv(sText, vbFromUnicode)))
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not iFont = 0 Then
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
End If
End Function
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
Public Function ExtTextOut(ByVal dblX As Double, ByVal dblY As Double, ByVal sText As String, Optional ByVal dblDx As Double, Optional iTextColor, _
Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, Optional bFontUnderline, Optional bFontStrikethrough) As Long
Dim oFont As New StdFont
Dim iFont As Long, iCount As Long, iDx() As Long, iI As Long
If dblX < 0 Or dblY < 0 Or sText = "" Then
Exit Function
End If
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not (IsMissing(iFontSize) And IsMissing(sFontName) And IsMissing(bFontBold) _
And IsMissing(bFontItalic) And IsMissing(bFontUnderline) And IsMissing(bFontStrikethrough)) Then
iFont = CreateFont(iFontSize, sFontName, bFontBold, bFontItalic, bFontUnderline, bFontStrikethrough)
iFont = SelectObject(lPrinterDC, iFont)
End If
dblDx = dblDx
iCount = LenB(StrConv(sText, vbFromUnicode))
ReDim iDx(iCount)
For iI = LBound(iDx) To UBound(iDx)
iDx(iI) = dblDx
Next
If dblDx <= 0 Then
Call ExtTextOutAPI(lPrinterDC, dblX, dblY, 0, ByVal 0, sText, iCount, ByVal 0)
Else
Call ExtTextOutAPI(lPrinterDC, dblX, dblY, 0, ByVal 0, sText, iCount, iDx(0))
End If
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not iFont = 0 Then
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
End If
End Function
'-------------------------------------------------------------
'功能：打印字符串
'入口：无
'出口：无
'-------------------------------------------------------------
Public Function DrawText(ByVal dblLeft As Double, ByVal dblTop As Double, ByVal dblRight As Double, ByVal dblBottom As Double, _
ByVal sText As String, ByVal iFormat As TextDrawFMT, Optional iTextColor, _
Optional iFontSize, Optional sFontName, Optional bFontBold, Optional bFontItalic, _
Optional bFontUnderline, Optional bFontStrikethrough) As Long
Dim rtRect As RECT
Dim iFont As Long
If dblLeft < 0 Or dblTop < 0 Or dblRight < 0 Or dblBottom < 0 Or sText = "" Then
Exit Function
End If
With rtRect
.Left = Int(dblLeft): .Top = Int(dblTop)
.Right = Int(dblRight): .Bottom = Int(dblBottom)
End With
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not (IsMissing(iFontSize) And IsMissing(sFontName) And IsMissing(bFontBold) _
And IsMissing(bFontItalic) And IsMissing(bFontUnderline) And IsMissing(bFontStrikethrough)) Then
iFont = CreateFont(iFontSize, sFontName, bFontBold, bFontItalic, bFontUnderline, bFontStrikethrough)
iFont = SelectObject(lPrinterDC, iFont)
End If
Call DrawTextAPI(lPrinterDC, sText, LenB(StrConv(sText, vbFromUnicode)), rtRect, iFormat Or IIf(iFormat And (FMT_VCENTER Or FMT_BOTTOM), DT_SINGLELINE, 0))
If Not IsMissing(iTextColor) And IsNumeric(iTextColor) Then
iTextColor = SetTextColorAPI(lPrinterDC, iTextColor)
End If
If Not iFont = 0 Then
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
End If
End Function
'-------------------------------------------------------------
'功能：打印图像
'入口：无
'出口：无
'技巧
' BitBlt Picture1.hdc, 0, 0, bm.bmWidth, bm.bmHeight, Picture2.hdc, 0, 0, vbSrcCopy
' StretchBlt Picture1.hdc, bm.bmWidth, 0, -bm.bmWidth, bm.bmHeight, Picture2.hdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopy '左右镜像
' StretchBlt Picture3.hdc, 0, bm.bmHeight, bm.bmWidth, -bm.bmHeight, Picture2.hdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopy '上下镜像
' StretchBlt Picture4.hdc, bm.bmWidth, bm.bmHeight, -bm.bmWidth, -bm.bmHeight, Picture2.hdc, 0, 0, bm.bmWidth, bm.bmHeight, vbSrcCopy '旋转180
' StretchBlt Picture2.hdc, 0, bm.bmHeight, bm.bmWidth, -bm.bmHeight \ 2, Picture2.hdc, 0, 0, bm.bmWidth, bm.bmHeight \ 2, vbSrcCopy '图片一半上下镜像
'-------------------------------------------------------------
Public Function BitBlt(lImagHandle As Long, Optional dRatio As Single, Optional dX As Single, Optional dY As Single, Optional dW As Single, Optional dH As Single, _
Optional sX As Single, Optional sY As Single, Optional sW As Single, Optional sH As Single) As Long
Dim lCompatibleDC As Long, bm As BITMAP, lOldImg As Long
lCompatibleDC = CreateCompatibleDC(lPrinterDC)
Call GetObject(lImagHandle, Len(bm), bm)
lOldImg = SelectObject(lCompatibleDC, lImagHandle)
dW = Switch(dRatio > 0, bm.bmWidth * dRatio, dW <= 0, bm.bmWidth, True, dW)
dH = Switch(dRatio > 0, bm.bmHeight * dRatio, dH <= 0, bm.bmHeight, True, dH)
sW = IIf(sW <= 0, bm.bmWidth, sW): sH = IIf(sH <= 0, bm.bmHeight, sH)
BitBlt = StretchBltAPI(lPrinterDC, dX, dY, dW, dH, lCompatibleDC, sX, sY, sW, sH, SRCCOPY)
Call SelectObject(lCompatibleDC, lOldImg)
Call DeleteDC(lCompatibleDC)
End Function
'--------------------------------------------------------------------
'功能：打开打印机
'入口：要打开打印机的名,为空取默认打印机
'出口：0-失败，其它--打印机的handle
'--------------------------------------------------------------------
Private Function OpenPrinter(Optional sPrinterName As String = "") As Long
Dim sDefaultName As String
OpenPrinter = 0
If sPrinterName = "" Then
sDefaultName = String(512, vbNullChar)
If GetDefaultPrinterAPI(sDefaultName, 512) = 0 Then
Exit Function
End If
sPrinterName = Left(sDefaultName, InStr(sDefaultName, vbNullChar) - 1)
End If
If OpenPrinterAPI(sPrinterName, OpenPrinter, 0) = 0 Then
OpenPrinter = 0
End If
End Function
'--------------------------------------------------------------------
'功能：关闭打印机,主要为了函数一致
'入口：要关闭打印机handle
'出口：true-成功
'--------------------------------------------------------------------
Private Function ClosePrinter(hPrintHandle As Long) As Boolean
ClosePrinter = (ClosePrinterAPI(hPrintHandle) <> 0)
End Function
'--------------------------------------------------------------------
'功能：返回打印机的所有名称
'入口：
'出口：打印机的所有名称,用vbCrLf分隔
'--------------------------------------------------------------------
Public Function EnumPrinters() As String
Dim pcbNeeded As Long, pcReturned As Long
Dim abpi() As Byte, pi5 As PRINTER_INFO_5
Call EnumPrintersAPI(PRINTER_ENUM_NAME, vbNullString, 5, ByVal 0, 0, pcbNeeded, pcReturned)
If pcbNeeded = 0 Then Exit Function
ReDim abpi(pcbNeeded) As Byte
If EnumPrintersAPI(PRINTER_ENUM_NAME, vbNullString, 5, abpi(0), pcbNeeded, pcbNeeded, pcReturned) = 0 Then Exit Function
For pcbNeeded = 0 To pcReturned - 1
CopyMemory pi5, abpi(Len(pi5) * pcbNeeded), Len(pi5)
EnumPrinters = EnumPrinters + IIf(EnumPrinters = "", "", vbCrLf) + PtrCtoVbString(pi5.pPrinterName)
Next
End Function
'--------------------------------------------------------------------
'功能：取打印机信息
'入口：要打印机handle
'出口：打印机信息，以vbcrlf分隔 flags，pName，pDescription，pComment
'--------------------------------------------------------------------
Public Function GetPrinterInfo(Optional hPrintHandle As Long) As String
Dim pi1 As PRINTER_INFO_1, lngNeeded As Long, bData() As Byte
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
Call GetPrinterAPI(hPrintHandle, 1, vbNull, 0, lngNeeded)
ReDim bData(lngNeeded) As Byte
If GetPrinterAPI(hPrintHandle, 1, bData(0), lngNeeded, lngNeeded) <> 0 Then
CopyMemory pi1, bData(0), Len(pi1)
GetPrinterInfo = "flags:" & pi1.flags & vbCrLf & _
"Name:" & PtrCtoVbString(pi1.pName) & vbCrLf & _
"Description:" & PtrCtoVbString(pi1.pDescription) & vbCrLf & _
"Comment:" & PtrCtoVbString(pi1.pComment)
End If
End Function
'--------------------------------------------------------------------
'功能：列举所有打印机支持的纸张
'入口：打印机handle
'出口：所有纸形，用vbcrlf分隔，各纸形参数用vbtab分隔
'--------------------------------------------------------------------
Public Function EnumForms(Optional hPrintHandle As Long) As String
Dim afi() As FORM_INFO_1, bTemp() As Byte
Dim lngNeeded As Long, lngReturned As Long
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
Call EnumFormsAPI(hPrintHandle, 1, vbNull, 0, lngNeeded, lngReturned)
If lngNeeded <= 0 Then
Exit Function
End If
ReDim bTemp(lngNeeded) As Byte
ReDim afi(1) As FORM_INFO_1
ReDim afi(lngNeeded / Len(afi(0))) As FORM_INFO_1
Call EnumFormsAPI(hPrintHandle, 1, bTemp(0), lngNeeded, lngNeeded, lngReturned)
If lngReturned <= 0 Then
Exit Function
End If
Call CopyMemory(afi(0), bTemp(0), lngNeeded)
For lngNeeded = 0 To lngReturned - 1
EnumForms = EnumForms & IIf(EnumForms = "", "", vbCrLf) & afi(lngNeeded).flags & vbTab & PtrCtoVbString(afi(lngNeeded).pName) & vbTab & _
afi(lngNeeded).SIZE.cx & vbTab & afi(lngNeeded).SIZE.cy & vbTab & _
Switch(afi(lngNeeded).flags = 0, "FORM_USER", afi(lngNeeded).flags = 1, "FORM_BUILTIN", afi(lngNeeded).flags = 2, "FORM_PRINTER", True, "FORM_ERROR")
Next
End Function
'--------------------------------------------------------------------
'功能：为打印机添加纸张
'入口：要打印机handle、名称、宽度、长度（单位：千分之一毫米）
'出口：true-成功
'--------------------------------------------------------------------
Public Function AddForm(pName As String, cx As Long, cy As Long, Optional hPrintHandle As Long) As Boolean
Dim fi As FORM_INFO_1_S, bfi() As Byte
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
If InStr(EnumForms(hPrintHandle), vbTab + pName + vbTab) > 0 Then
DeleteForm pName, hPrintHandle '已存在，则删除
End If
With fi
.flags = 0
.pName = pName
.SIZE.cx = cx
.SIZE.cy = cy
.ImageableArea.Left = 0
.ImageableArea.Top = 0
.ImageableArea.Bottom = cy
.ImageableArea.Right = cx
End With
ReDim bfi(Len(fi)) As Byte
Call CopyMemory(bfi(0), fi, Len(fi))
AddForm = (AddFormAPI(hPrintHandle, 1, bfi(0)) <> 0)
End Function
'--------------------------------------------------------------------
'功能：删除自定义纸张
'入口：要打印机handle、名称
'出口：true-成功
'--------------------------------------------------------------------
Public Function DeleteForm(pName As String, Optional hPrintHandle As Long) As Boolean
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
DeleteForm = (DeleteFormAPI(hPrintHandle, pName) <> 0)
End Function
'--------------------------------------------------------------------
'功能：取打印机的默认页形
'入口：要打印机handle
'出口：默认页形
'--------------------------------------------------------------------
Public Function FormDefault(Optional hPrintHandle As Long) As String
Dim sPrintName As String, nSize As Long, pDevMode As DEVMODE, aDevMode() As Byte
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
sPrintName = GetPrinterInfo(hPrintHandle)
If sPrintName = "" Then
Exit Function
End If
sPrintName = Mid(sPrintName, InStr(sPrintName, "Name:") + 5)
sPrintName = Left(sPrintName, IIf(InStr(sPrintName, vbCrLf) > 0, InStr(sPrintName, vbCrLf) - 1, 0))
nSize = DocumentProperties(vbNull, hPrintHandle, sPrintName, 0&, 0&, 0&)
If nSize <= 0 Then
Exit Function
End If
ReDim aDevMode(nSize - 1) As Byte
nSize = DocumentProperties(vbNull, hPrintHandle, sPrintName, aDevMode(0), 0&, DM_OUT_BUFFER)
If nSize <= 0 Then
Exit Function
End If
Call CopyMemory(pDevMode, aDevMode(0), Len(pDevMode))
FormDefault = Left(pDevMode.dmFormName, IIf(InStr(pDevMode.dmFormName, vbNullChar) > 0, InStr(pDevMode.dmFormName, vbNullChar) - 1, Len(pDevMode.dmFormName)))
If FormDefault = "" And pDevMode.dmPaperSize > 0 Then
FormDefault = EnumForms()
If pDevMode.dmPaperSize <= UBound(Split(FormDefault, vbCrLf)) + 1 Then
FormDefault = Split(FormDefault, vbCrLf)(pDevMode.dmPaperSize - 1)
FormDefault = Mid(FormDefault, InStr(FormDefault, vbTab) + 1, InStr(InStr(FormDefault, vbTab) + 1, FormDefault, vbTab) - InStr(FormDefault, vbTab) - 1)
Else
FormDefault = ""
End If
End If
End Function
'--------------------------------------------------------------------
'功能：取打印机的页形的尺寸
'入口：要打印机handle，页形名称
'出口：页形的尺寸 以vbcrlf分隔
'--------------------------------------------------------------------
Public Function FormSize(Optional ByVal sFormName As String, Optional hPrintHandle As Long) As String
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
If sFormName = "" Then sFormName = FormDefault(hPrintHandle)
Dim fi1 As FORM_INFO_1, cbNeeded As Long, afi1() As Byte
Call GetFormAPI(hPrintHandle, sFormName, 1, ByVal 0, 0, cbNeeded)
If cbNeeded = 0 Then Exit Function
ReDim afi1(cbNeeded) As Byte
If GetFormAPI(hPrintHandle, sFormName, 1, afi1(0), cbNeeded, cbNeeded) = 0 Then Exit Function
CopyMemory fi1, afi1(0), Len(fi1)
FormSize = fi1.SIZE.cx & vbCrLf & fi1.SIZE.cy
End Function
'--------------------------------------------------------------------
'功能：取打印机驱动
'入口：要打印机handle
'出口：打印机驱动名
'--------------------------------------------------------------------
Public Function GetPrinterDriver(Optional hPrintHandle As Long) As String
Dim pi2 As PRINTER_INFO_2, pcbNeeded As Long, bTmp() As Byte
hPrintHandle = IIf(hPrintHandle = 0, lPrinterHandle, hPrintHandle)
If hPrintHandle = 0 Then
hPrintHandle = OpenPrinter()
lPrinterHandle = hPrintHandle
End If
Call GetPrinterAPI(hPrintHandle, 2, ByVal 0, 0, pcbNeeded)
If pcbNeeded <= 0 Then Exit Function
ReDim bTmp(pcbNeeded) As Byte
If GetPrinterAPI(hPrintHandle, 2, bTmp(0), pcbNeeded, pcbNeeded) = 0 Then Exit Function
CopyMemory pi2, bTmp(0), Len(pi2)
GetPrinterDriver = "ServerName:" & PtrCtoVbString(pi2.pServerName) & vbCrLf & _
"PrinterName:" & PtrCtoVbString(pi2.pPrinterName) & vbCrLf & _
"ShareName:" & PtrCtoVbString(pi2.pShareName) & vbCrLf & _
"PortName:" & PtrCtoVbString(pi2.pPortName) & vbCrLf & _
"DriverName:" & PtrCtoVbString(pi2.pDriverName) & vbCrLf & _
"Comment:" & PtrCtoVbString(pi2.pComment) & vbCrLf & _
"Location:" & PtrCtoVbString(pi2.pLocation) & _
"SepFile:" & PtrCtoVbString(pi2.pSepFile) & vbCrLf & _
"PrintProcessor:" & PtrCtoVbString(pi2.pPrintProcessor) & vbCrLf & _
"Datatype:" & PtrCtoVbString(pi2.pDatatype) & vbCrLf & _
"Parameters:" & PtrCtoVbString(pi2.pParameters) & vbCrLf & _
"Attributes:" & pi2.Attributes & vbCrLf & _
"Priority:" & pi2.Priority & vbCrLf & _
"DefaultPriority:" & pi2.DefaultPriority & vbCrLf & _
"StartTime:" & pi2.StartTime & vbCrLf & _
"UntilTime:" & pi2.UntilTime & vbCrLf & _
"Status:" & pi2.Status & vbCrLf & _
"cJobs:" & pi2.cJobs & vbCrLf & _
"AveragePPM:" & pi2.AveragePPM
'返回结构式
' With PrinterGetPrinterDriver
' .pServerName = PtrCtoVbString(pi2.pServerName)
' .pPrinterName = PtrCtoVbString(pi2.pPrinterName)
' .pShareName = PtrCtoVbString(pi2.pShareName)
' .pPortName = PtrCtoVbString(pi2.pPortName)
' .pDriverName = PtrCtoVbString(pi2.pDriverName)
' .pComment = PtrCtoVbString(pi2.pComment)
' .pLocation = PtrCtoVbString(pi2.pLocation)
' CopyMemory .pDevMode, ByVal pi2.pDevMode, Len(.pDevMode)
' .pSepFile = PtrCtoVbString(pi2.pSepFile)
' .pPrintProcessor = PtrCtoVbString(pi2.pPrintProcessor)
' .pDatatype = PtrCtoVbString(pi2.pDatatype)
' .pParameters = PtrCtoVbString(pi2.pParameters)
' CopyMemory .pSecurityDescriptor, ByVal pi2.pSecurityDescriptor, Len(.pSecurityDescriptor)
' .Attributes = pi2.Attributes
' .Priority = pi2.Priority
' .DefaultPriority = pi2.DefaultPriority
' .StartTime = pi2.StartTime
' .UntilTime = pi2.UntilTime
' .Status = pi2.Status
' .cJobs = pi2.cJobs
' .AveragePPM = pi2.AveragePPM
' End With
End Function
'-------------------------------------------------------------
'功能：结束打印，释放资源
'入口：无
'出口：如果模拟显示，返回一个标准StdPicture
'-------------------------------------------------------------
Public Function PrinterEnd() As StdPicture
Dim iFont As Long
If Not (lPrinterDC = 0) Then
If isPrinter Then
Call EndPageAPI(lPrinterDC)
Call EndDocAPI(lPrinterDC)
End If
'释放创建字体，如果是系统默认字体，也可以释放，不影响系统
iFont = GetStockObject(SYSTEM_FONT)
iFont = SelectObject(lPrinterDC, iFont)
Call DeleteObject(iFont)
Call DeleteDC(lPrinterDC): lPrinterDC = 0
Call DeleteDC(lPictureDC): lPictureDC = 0
'保存成图像
If Not isPrinter Then Set PrinterEnd = imgHandl2StdPicture(lPictureHandle, True)
End If
If Not (lPrinterHandle = 0) Then
Call ClosePrinter(lPrinterHandle)
lPrinterHandle = 0
End If
End Function
'*******************************************************************
'* 你可以使用系统函数ResetDC()，而不使用setprinter()。试试看吧。 *
'*******************************************************************
'-----------------------------------------------------------------------------------------------------+
'功能：启动打印机设备，返回打印DC，直接操作DC |
'入口：sDeviceName 设备名称（DISPLAY-屏幕,其它为打印机名称，如果打印机名不存在，为默认打印机） |
' iPageWidth 纸面宽度, iPageHeight 纸面高度 （为零时，由纸张名称取长、宽,单位毫米） |
' sFormName 纸张名称，为空取默认, iOrientation 纸张放置方向 vbPRORPortrait, bReverse:反向打印 |
'出口：打印机DC |
'不用设置纸形，直接设置DC，兼容性强 |
'-----------------------------------------------------------------------------------------------------+
Public Function PrinterStart(Optional ByVal sPrinterName As String, Optional ByVal sFormName As String, _
Optional ByVal iOrientation As PrinterObjectConstants = 0, _
Optional ByVal dblPageWidth As Single, Optional ByVal dblPageHeight As Single, Optional bReverse As Boolean) As Long
Dim dmData As DEVMODE
Dim di As DOCINFO
Dim iLogPixeLSX As Long, iLogPixeLSY As Long '每英寸多少点
Dim iPageWidth As Long, iPageHeight As Long
Dim sTmp As String, saTmp() As String, baTmp() As Byte
Dim iI As Long, rtPage As RECT
If Not (lPrinterDC = 0) Then
Call PrinterEnd
End If
isPrinter = Not (UCase(sPrinterName) = "DISPLAY")
iPageWidth = Int(dblPageWidth * 1000): iPageHeight = Int(dblPageHeight * 1000):
'打开打印机，需要取纸型的大小
sTmp = GetPrinterDriver()
If lPrinterHandle = 0 Then
lPrinterHandle = OpenPrinter(sPrinterName)
ElseIf isPrinter And Not (sPrinterName = "") Then
'确保打开的打印机为指定打印机
If (InStr(sTmp, sPrinterName) = 0) Then
Call ClosePrinter(lPrinterHandle): lPrinterHandle = 0
lPrinterHandle = OpenPrinter(sPrinterName)
sTmp = GetPrinterDriver()
End If
End If
sPrinterName = sTmp: sTmp = ""
'取纸形的大小
sFormName = IIf(sFormName = "", FormDefault(lPrinterHandle), sFormName)
If InStr(EnumForms(lPrinterHandle), sFormName) = 0 And _
(iPageHeight = 0 Or iPageWidth = 0) Then
Err.Raise 9999, , "指定纸形不存在，纸形的长、宽零，无法打印！【解决方案：指定存在的纸型或指定长和宽的大小，单位0.001毫米】"
Exit Function
End If
If iPageWidth = 0 Or iPageHeight = 0 Then
saTmp = Split(FormSize(sFormName, lPrinterHandle), vbCrLf)
If Not (UBound(saTmp) = 1) Then
Err.Raise 9999, , "无法取到指定纸形的长、宽！"
Exit Function
End If
iPageHeight = IIf(iPageHeight > 0, iPageHeight, CLng(saTmp(1)))
iPageWidth = IIf(iPageWidth > 0, iPageWidth, CLng(saTmp(0)))
End If
'创建DC
'1、取创建DC的DEVMODE
If isPrinter Then
saTmp = Split(sPrinterName, vbCrLf)
'取打印机DEVMODE,用于建DC
iI = DocumentProperties(ByVal 0, lPrinterHandle, Mid(saTmp(4), InStr(saTmp(4), ":") + 1), ByVal 0&, ByVal 0&, ByVal 0&)
If iI <= 0 Then
Err.Raise 9999, , "取打印机信息缓冲区大小失败！"
Exit Function
End If
ReDim baTmp(iI)
iI = DocumentProperties(ByVal 0, lPrinterHandle, Mid(saTmp(4), InStr(saTmp(4), ":") + 1), baTmp(0), ByVal 0&, DM_OUT_BUFFER)
CopyMemory dmData, baTmp(0), Len(dmData)
'设置打印纸型
With dmData
.dmFields = DM_PAPERLENGTH Or DM_PAPERWIDTH Or DM_PAPERSIZE Or _
IIf(iOrientation = 2, DM_ORIENTATION, 0) 'vbPRORLandscape=2
.dmPaperSize = &H100
.dmPaperLength = iPageHeight / 100 '十分之一毫米为单位
.dmPaperWidth = iPageWidth / 100 '十分之一毫米为单位
.dmOrientation = iOrientation
.dmSize = LenB(dmData)
End With
'取设置打印机DC的DEVMODE完成
' Call ResetDC(iPrinterDC, dmData) '后期更改打印机参数
'创建打印机DC CreateDC(sDriverName + vbNullChar, sPrinterName + vbNullChar, sPortName + vbNullChar, dmData)
lPrinterDC = CreateDC(Mid(saTmp(4), InStr(saTmp(4), ":") + 1) & vbNullChar, _
Mid(saTmp(1), InStr(saTmp(1), ":") + 1) & vbNullChar, _
Mid(saTmp(3), InStr(saTmp(3), ":") + 1) & vbNullChar, _
dmData)
Else
'取设置n屏幕DC的DEVMODE被忽略
lPictureDC = CreateDC("DISPLAY", ByVal 0, ByVal 0, ByVal 0)
lPrinterDC = CreateCompatibleDC(lPictureDC)
'lPrinterDC = CreateCompatibleDC(ByVal 0)
End If
'设置打印机状态
If lPrinterDC = 0 Then
Err.Raise 9999, , "创建打印机DC失败！"
Exit Function
End If
'设置 Window 和 Viewport
iLogPixeLSX = GetDeviceCaps(lPrinterDC, LOGPIXELSX)
iLogPixeLSY = GetDeviceCaps(lPrinterDC, LOGPIXELSY)
'创建bmp句柄
If Not isPrinter Then
iPageHeight = iPageHeight / 25400 * iLogPixeLSY: iPageWidth = iPageWidth / 25400 * iLogPixeLSX
If iOrientation = 2 Then '
iI = iPageHeight: iPageHeight = iPageWidth: iPageWidth = iI
End If
lPictureHandle = CreateCompatibleBitmap(lPictureDC, iPageWidth, iPageHeight)
Call SelectObject(lPrinterDC, lPictureHandle) '附加到DC
'刷成白色
iI = GetStockObject(WHITE_BRUSH)
rtPage.Bottom = iPageHeight + 10: rtPage.Right = iPageWidth + 10
Call FillRect(lPrinterDC, rtPage, iI)
Call DeleteObject(iI): iI = 0
End If
Call SetMapMode(lPrinterDC, MM_ANISOTROPIC) 'MM_ANISOTROPIC,MM_LOENGLISH,如果直接设成MM_LOENGLISH，则显示有差误，原因Windows在显示时以"逻辑英寸"为单位,逻辑英寸比实际的英寸要大。
'处理打印纵、横分辨率不一样的情况， 1英寸(in)=2.54厘米(cm)
Call SetWindowExtEx(lPrinterDC, 254, 254, ByVal 0)
Call SetViewportExtEx(lPrinterDC, iLogPixeLSX, iLogPixeLSY, ByVal 0) '1英寸(in)=2.54厘米(cm)=25.4毫米(mm)=254 0.1毫米(0.1mm)[纸张大小定义]
Call SetBkMode(lPrinterDC, TRANSPARENT)
DoEvents
If isPrinter Then
'打开文档
di.lpszDocName = "printTable" & vbNullChar: di.lpszOutput = vbNullString: di.cbSize = Len(di)
Call StartDocAPI(lPrinterDC, di)
Call StartPageAPI(lPrinterDC)
End If
'反射打印，先打印尾部，再打印头部，相当于纸张旋转180度
If bReverse Then Call SetMode(MD_LEFTTOP2RIGHTBOTTOM)
PrinterStart = lPrinterDC
End Function
'-----------------------------------------------------------------------------------------------------+
'功能：设置打印的镜像方向 |
'入口：镜像方向 |
'出口：无 |
'-----------------------------------------------------------------------------------------------------+
Public Sub SetMode(iMd As MIRRORDIRECTION)
Dim xf As XFORM
Dim iWidth As Long, iHeight As Long
Dim bm As BITMAP
If SetGraphicsMode(lPrinterDC, GM_ADVANCED) = 0 Then Exit Sub
If isPrinter Then
iWidth = GetDeviceCaps(lPrinterDC, HORZSIZE) * 10
iHeight = GetDeviceCaps(lPrinterDC, VERTSIZE) * 10
Else
Call GetObject(lPictureHandle, LenB(bm), bm)
iWidth = bm.bmWidth * 254 / GetDeviceCaps(lPrinterDC, LOGPIXELSX)
iHeight = bm.bmHeight * 254 / GetDeviceCaps(lPrinterDC, LOGPIXELSY)
End If
'设置变换矩阵，*10是因为逻辑坐标放大了10倍
With xf
.eM11 = IIf(iMd And 1, -1, 1)
.eM12 = 0
.eM21 = 0
.eM22 = IIf(iMd And 2, -1, 1)
.eDx = IIf(iMd And 1, iWidth, 1) ' / 25.4 * GetDeviceCaps(.hdc, LOGPIXELSX)
.eDy = IIf(iMd And 2, iHeight, 1) ' / 25.4 * GetDeviceCaps(.hdc, LOGPIXELSY)
End With
Call SetWorldTransform(lPrinterDC, xf)
End Sub
'-------------------------------------------------------------
'功能：结束当前页打印，开始新的一页
'入口：无
'出口：无
'-------------------------------------------------------------
Public Sub NewPage()
If Not (lPrinterDC = 0) Then
Call EndPageAPI(lPrinterDC)
DoEvents
Call StartPageAPI(lPrinterDC)
End If
End Sub
先放代码
原因：
使用epson喷墨打印机打印信封时，发现正常进纸进不了，旋转180度可以进纸，没有办法，只能选择将字体旋转180度再打印。
有几种解决方案
一、CreateFont 时将参数 int nEscapement/* angle of escapement*/ 设为1800
这样可以打印时打印出旋转180度的文字。效果如下
这个可以调整打印开始位置结解决，使用DrawText 自动换行打印，处理麻烦。于是有了第二个方案
二、打印完成后，将打印机DC的内容旋转180度。可是试验了许多方式，无法处理打印机DC的内容。用BitBlt函数将内容复制都没有结果，更不用转移到屏幕DC，有方案说可以通过DIB进行数据传送，没试，麻烦。这部分最好用VC进行测试，机器太老，不想安装庞大VC开发环境。为什么用vba,方便，打开excl、word、ppt都的VBA环境，调整程序方便。一个好的VB程序员，不懂VC、asm，根本行不通！懒得付出太多。试试SetWorldTransform函数。使用SetWorldTransform，必须GDI+才行，也就是高级模式， SetGraphicsMode(PrinterDC, GM_ADVANCED)，一试，打印机DC支持ADVANCED模式
三使用GDI的ADVANCED模式，用SetWorldTransform对DC进行任意放缩、旋转、平移。原理不多讲放公式，有高数知识的人，能看懂！
| eM11 eM12 0 |
k*|x,y,1|* | eM21 eM22 0 | =|x1,y1,d1|
| eDx eDy 1 |
k--放缩因子，eM11,eM12,eM21,eM22--旋转因子；eDx,eDy--平移因子
这些参数怎么设置，就不多说了，如果学三维处理，不懂这个 ，难！难！难！难！有人说，我不懂，照样可以很好的完成任务。哪是变换矩阵被包装了，容易使用，想升级就验了。 SetWorldTransform更改变换矩阵，涉及浮点数计算，图像的清晰度就会下降。
本程序只使用了90度、180度、270度三个特殊的角度，对图像没有太大的影响。
下面是处理效果：
打印界面
上图是旋转180度打印结果，图上标识错误
其它相关技巧，关注本个的个人网战https://wjjhyf.eu5.org
https://wjjhyf.eu5.org
扫一扫
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
