Option Explicit '该模块用于协调打印机 和打印预览控件 '使预览结果和打印结果一样 '，从别处复制又修改过的，可能有错误 ' Private Type BITMAPINFOHEADER_TYPE     biSize As Long     biWidth As Long     biHeight As Long     biPlanes As Long     biBitCount As Long     biCompression As Long     biSizeImage As Long     biXPelsPerMeter As Long     biYPelsPerMeter As Long     biClrUsed As Long     biClrImportant As Long     bmiColors As String * 1024 End Type Private Type BITMAPINFO_TYPE     BitmapInfoHeader As BITMAPINFOHEADER_TYPE     bmiColors As String * 1024 End Type ' Enter each of the following Declare statements as one, single line: Private Declare Function GetDIBits Lib "gdi32" (ByVal hDC As Long, ByVal hBitmap As Long, ByVal nStartScan As Long, ByVal nNumScans As Long, ByVal lpBits As Long, BitmapInfo As BITMAPINFO_TYPE, ByVal wUsage As Long) As Long Private Declare Function StretchDIBits Lib "gdi32" (ByVal hDC As Long, ByVal DestX As Long, ByVal DestY As Long, ByVal wDestWidth As Long, ByVal wDestHeight As Long, ByVal SrcX As Long, ByVal SrcY As Long, ByVal wSrcWidth As Long, ByVal wSrcHeight As Long, ByVal lpBits As Long, BitsInfo As BITMAPINFO_TYPE, ByVal wUsage As Long, ByVal dwRop As Long) As Long Private Declare Function GlobalAlloc Lib "kernel32" (ByVal wFlags As Long, ByVal lMem As Long) As Long Private Declare Function GlobalLock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalUnlock Lib "kernel32" (ByVal hMem As Long) As Long Private Declare Function GlobalFree Lib "kernel32" (ByVal hMem As Long) As Long Const SRCCOPY = &HCC0020 Const BI_RGB = 0 Const DIB_RGB_COLORS = 0 Const GMEM_MOVEABLE = 2 '保持属性值的局部变量 Private mvarpaperSize As Long '纸张大小 Private m_PaperWidth As Single Private m_PaperHeight As Single Private mvarleftGap As Single '局部复制 Private mvarrightGap As Single '局部复制 Private mvartopGap As Single '局部复制 Private mvarbottomGap As Single '局部复制 Private mvarCurrentX As Single '局部复制 Private mvarCurrentY As Single '局部复制 Private mvarFontName As String '局部复制 Private mvarFontSize As String '局部复制 Dim ObjPrint As Object '用哪个控件来进行预览 Dim toview As Boolean '是否要进行预览 Dim Ratio As Single '预览时候的字体显示比例 Dim sm As Long '记录最初时的scaleMode Dim LRGap As Single Dim TBgap As Single '保持属性值的局部变量 Private mvarOrientation As Long '局部复制 Public Function StartDoc(objToPrintOn As Variant, ByVal toViewObj As Boolean) As Boolean   ', ByVal PaperWidth As Single, ByVal PaperHeight As Single) Dim psm As Long On Error GoTo errout     toview = toViewObj     If mvarpaperSize <> 0 And mvarpaperSize <> 256 Then         Printer.paperSize = mvarpaperSize     ElseIf mvarpaperSize = 256 Then         Printer.width = m_PaperWidth         Printer.height = m_PaperHeight     End If     If mvarOrientation = 1 Or mvarOrientation = 2 Then         Printer.Orientation = mvarOrientation     End If     sm = Printer.ScaleMode     Printer.ScaleMode = 7 '厘米     If toview = False Then         Printer.FontTransparent = True     Else         Set ObjPrint = objToPrintOn         ObjPrint.ScaleMode = 7         psm = ObjPrint.Parent.ScaleMode         ObjPrint.Parent.ScaleMode = 7         ObjPrint.height = (ObjPrint.ScaleWidth / Printer.ScaleWidth) * Printer.ScaleHeight         Ratio = ObjPrint.ScaleWidth / Printer.ScaleWidth         ObjPrint.Scale (0, 0)-(CSng(Printer.ScaleWidth), CSng(Printer.ScaleHeight))         ObjPrint.Parent.ScaleMode = psm ' ' '        Set ObjPrint.Font = Printer.Font '        ObjPrint.Font.Size = Printer.Font.Size * Ratio         ObjPrint.ForeColor = Printer.ForeColor         ObjPrint.FontTransparent = True         ObjPrint.Cls     End If     StartDoc = True     Exit Function errout:     MsgBox "打印机错误", vbInformation     StartDoc = False End Function Public Sub EndDoc() If toview = False Then          Printer.EndDoc     Printer.ScaleMode = sm End If End Sub Public Sub PrintPicture(picSource As Object, ByVal pLeft As Single, ByVal pTop As Single, ByVal pWidth As Single, ByVal pHeight As Single) '下面这一段为图形打印，有些变量还没搞清楚       Dim BitmapInfo As BITMAPINFO_TYPE       Dim DesthDC As Long       Dim hMem As Long       Dim lpBits As Long       Dim r As Long       ' Precaution: '      If pLeft < LRGap Or pTop < TBgap Then Exit Sub '      If pWidth < 0 Or pHeight < 0 Then Exit Sub '      If pWidth + pLeft > PgWidth - LRGap Then Exit Sub '      If pHeight + pTop > PgHeight - TBgap Then Exit Sub       picSource.ScaleMode = 3 'Pixels       picSource.AutoRedraw = False       picSource.Visible = False       picSource.AutoSize = True       If toview = False Then         Printer.ScaleMode = 3 'Pixels         ' Calculate size in pixels:         pLeft = ((pLeft - LRGap) * 1440) / Printer.TwipsPerPixelX         pTop = ((pTop - TBgap) * 1440) / Printer.TwipsPerPixelY         pWidth = (pWidth * 1440) / Printer.TwipsPerPixelX         pHeight = (pHeight * 1440) / Printer.TwipsPerPixelY         Printer.Print ""         DesthDC = Printer.hDC       Else         ObjPrint.Scale         ObjPrint.ScaleMode = 3 'Pixels         ' Calculate size in pixels:         pLeft = ((pLeft * 1440) / Screen.TwipsPerPixelX) * Ratio         pTop = ((pTop * 1440) / Screen.TwipsPerPixelY) * Ratio         pWidth = ((pWidth * 1440) / Screen.TwipsPerPixelX) * Ratio         pHeight = ((pHeight * 1440) / Screen.TwipsPerPixelY) * Ratio         DesthDC = ObjPrint.hDC       End If       BitmapInfo.BitmapInfoHea der.biSize = 40       BitmapInfo.BitmapInfoHea der.biWidth = picSource.ScaleWidth       BitmapInfo.BitmapInfoHea der.biHeight = picSource.ScaleHeight       BitmapInfo.BitmapInfoHea der.biPlanes = 1       BitmapInfo.BitmapInfoHea der.biBitCount = 8       BitmapInfo.BitmapInfoHea der.biCompression = BI_RGB       ' Enter the following two lines as one, single line:       hMem = GlobalAlloc(GMEM_MOVEABLE, (CLng(picSource.ScaleWidth + 3) \ 4) * 4 * picSource.ScaleHeight)      &n bsp; 'DWORD ALIGNED       lpBits = GlobalLock(hMem)       ' Enter the following two lines as one, single line:       r = GetDIBits(picSource.hDC, picSource.Image, 0, picSource.ScaleHeight, lpBits, BitmapInfo, DIB_RGB_COLORS)       If r <> 0 Then         ' Enter the following two lines as one, single line:         r = StretchDIBits(DesthDC, pLeft, pTop, pWidth, pHeight, 0, 0, picSource.ScaleWidth, picSource.ScaleHeight, lpBits, BitmapInfo, DIB_RGB_COLORS, SRCCOPY)       End If       r = GlobalUnlock(hMem)       r = GlobalFree(hMem)       If toview = False Then         Printer.ScaleMode = 5 'Inches       Else         ObjPrint.ScaleMode = 5 'Inches         'ObjPrint.Scale (0, 0)-(PgWidth, PgHeight)       End If End Sub Public Sub NewPage()       If toview = False Then         Printer.NewPage       Else         ObjPrint.Cls       End If End Sub Public Sub DrawCircle(ByVal bLeft As Single, ByVal bTop As Single, ByVal bRadius As Single) '    If PrinterFlag Then '       Printer.Circle (bLeft - LRGap, bTop - TBgap), bRadius '    Else '       ObjPrint.Circle (bLeft, bTop), bRadius '    End If End Sub Public Sub DrawFilledBox(ByVal bLeft As Single, ByVal bTop As Single, ByVal bWidth As Single, ByVal bHeight As Single, ByVal Color As Long)     If toview = False Then        ' Enter the following two lines as one, single line:        Printer.Line (bLeft - LRGap, bTop - TBgap)-(bLeft + bWidth - LRGap, bTop + bHeight - TBgap), Color, BF     Else        ' Enter the following two lines as one, single line:        ObjPrint.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), Color, BF     End If End Sub Public Sub DrawBox(ByVal bLeft As Single, ByVal bTop As Single, ByVal bWidth As Single, ByVal bHeight As Single)     If toview = False Then        ' Enter the following two lines as one, single line:        Printer.Line (bLeft - LRGap, bTop - TBgap)-(bLeft + bWidth - LRGap, bTop + bHeight - TBgap), , B     Else        ObjPrint.Line (bLeft, bTop)-(bLeft + bWidth, bTop + bHeight), , B     End If End Sub Public Sub DrawLine(ByVal bLeft0 As Single, ByVal bTop0 As Single, ByVal bLeft1 As Single, ByVal bTop1 As Single, Optional Color As Long = 0, Optional LineWidth As Long = 1) Dim oldDrawWidth As Long     If toview = False Then        ' Enter the following two lines as one, single line:        oldDrawWidth = Printer.DrawWidth        Printer.DrawWidth = LineWidth        Printer.Line (bLeft0 - LRGap, bTop0 - TBgap)-(bLeft1 - LRGap, bTop1 - TBgap), Color         Printer.DrawWidth = oldDrawWidth     Else         oldDrawWidth = ObjPrint.DrawWidth         ObjPrint.DrawWidth = LineWidth        ObjPrint.Line (bLeft0, bTop0)-(bLeft1, bTop1), Color        ObjPrint.DrawWidth = oldDrawWidth     End If End Sub Public Sub PrintString(ByVal str As String)     If toview = False Then        Printer.Print str     Else        ObjPrint.Print str     End If End Sub Public Property Let FontSize(ByVal vData As Single) '向属性指派值时使用，位于赋值语句的左边。 'Syntax: X.FontSize = 5     mvarFontSize = vData     If toview = False Then         Printer.FontSize = vData     Else         ' Sized by ratio since Scale method does not effect FontSize:         ObjPrint.FontSize = vData * Ratio     End If End Property Public Property Get FontSize() As Single '检索属性值时使用，位于赋值语句的右边。 'Syntax: Debug.Print X.FontSize     If toview = False Then         FontSize = Printer.FontSize     Else         FontSize = ObjPrint.FontSize / Ratio     End If End Property Public Property Let FontName(ByVal vData As String) '向属性指派值时使用，位于赋值语句的左边。 'Syntax: X.FontName = 5     mvarFontName = vData     If toview = False Then         Printer.FontName = vData     Else         ObjPrint.FontName = vData     End If End Property Public Property Get FontName() As String '检索属性值时使用，位于赋值语句的右边。 'Syntax: Debug.Print X.FontName     If toview = False Then         FontName = Printer.FontName     Else         FontName = ObjPrint.FontName     End If End Property Public Property Let CurrentY(ByVal vData As Single)     mvarCurrentY = vData     If toview = False Then         Printer.CurrentY = vData - TBgap     Else         ObjPrint.CurrentY = vData     End If End Property Public Property Get CurrentY() As Single     If toview = False Then         CurrentY = Printer.CurrentY + TBgap     Else         CurrentY = ObjPrint.CurrentY     End If End Property Public Property Let CurrentX(ByVal vData As Single)     mvarCurrentX = vData     If toview = False Then         Printer.CurrentX = vData - LRGap     Else         ObjPrint.CurrentX = vData     End If End Property Public Property Get CurrentX() As Single     If toview = False Then         CurrentX = Printer.CurrentX + LRGap     Else         CurrentX = ObjPrint.CurrentX     End If End Property Public Property Let bottomGap(ByVal vData As Single)     mvarbottomGap = vData End Property Public Property Get bottomGap() As Single     bottomGap = mvarbottomGap End Property Public Property Let topGap(ByVal vData As Single)     mvartopGap = vData End Property Public Property Get topGap() As Single     topGap = mvartopGap End Property Public Property Let rightGap(ByVal vData As Single)     mvarrightGap = vData End Property Public Property Get rightGap() As Single     rightGap = mvarrightGap End Property Public Property Let leftGap(ByVal vData As Single)     mvarleftGap = vData End Property Public Property Get leftGap() As Single     leftGap = mvarleftGap End Property Public Property Let paperSize(ByVal vData As mg_paperSizeList) On Error GoTo errout     mvarpaperSize = vData errout: End Property Public Property Get paperSize() As Long ' End Property Public Property Let Orientation(ByVal vData As Long)     mvarOrientation = vData End Property Public Property Get Orientation() As Long     Orientation = mvarOrientation End Property Public Property Get Font() As StdFont ' End Property Public Property Let Font(ByVal vNewValue As StdFont)     If toview = False Then         Printer.FontSize = vNewValue.Size         Printer.FontName = vNewValue.name         Printer.FontBold = vNewValue.Bold         Printer.FontUnderline = vNewValue.Underline         Printer.FontItalic = vNewValue.Italic     Else         ObjPrint.FontSize = vNewValue.Size * Ratio         ObjPrint.FontName = vNewValue.name         ObjPrint.FontBold = vNewValue.Bold         ObjPrint.FontUnderline = vNewValue.Underline         ObjPrint.FontItalic = vNewValue.Italic     End If     'Debug.Print "inclass " & vNewValue.Size End Property Public Property Set Font(ByVal vNewValue As StdFont)     If toview = False Then         Printer.FontSize = vNewValue.Size         Printer.FontName = vNewValue.name         Printer.FontBold = vNewValue.Bold         Printer.FontUnderline = vNewValue.Underline         Printer.FontItalic = vNewValue.Italic     Else         ObjPrint.FontSize = vNewValue.Size * Ratio         ObjPrint.FontName = vNewValue.name         ObjPrint.FontBold = vNewValue.Bold         ObjPrint.FontUnderline = vNewValue.Underline         ObjPrint.FontItalic = vNewValue.Italic     End If     'Debug.Print "inclass " & vNewValue.Size End Property Public Property Get PaperHeight() As Single     PaperHeight = m_PaperHeight End Property Public Property Let PaperHeight(ByVal vNewValue As Single)     m_PaperHeight = vNewValue End Property Public Property Get PaperWidth() As Single     PaperWidth = m_PaperWidth End Property Public Property Let PaperWidth(ByVal vNewValue As Single)     m_PaperWidth = vNewValue End Property

评论