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

评论