clstableprint.cls

一个VB表格控件

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
END
Attribute VB_Name = "clsTablePrint"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'############################################
'# Grid printing class                      #
'# Author: Jonas Wolz ([e-mail])    #
'#------------------------------------------#
'# You are free to use this class in your   #
'# own projects (without paying me a fee).  #
'# If you redistribute this class in        #
'# source form a notification would be      #
'# appreciated.                             #
'# This project comes with absolutely NO    #
'# warranty ! Use it at your own risk !!!   #
'# Please note: I've created the raw        #
'# structure of this class with the class   #
'# builder utility (I didn't want to write  #
'# all those Property Gets and Lets). So    #
'# the German comments inside most of those #
'# Property Get/Lets (and near private      #
'# variables) are only the utility's        #
'# standard comments. (Don't get confused   #
'# by them)                                 #
'############################################

Private Type RECT
        Left As Long
        Top As Long
        Right As Long
        Bottom As Long
End Type

Private Declare Function DrawText 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 Const DT_LEFT = &H0
Private Const DT_CENTER = &H1
Private Const DT_NOPREFIX = &H800
Private Const DT_RIGHT = &H2
Private Const DT_SINGLELINE = &H20
Private Const DT_VCENTER = &H4
Private Const DT_CALCRECT = &H400
Private Const DT_WORDBREAK = &H10
Private Const c_DTDefFmt = DT_NOPREFIX 'Or DT_SINGLELINE Or DT_VCENTER


Public Enum EAlignment
    eRight = DT_RIGHT
    eLeft = DT_LEFT
    eCenter = DT_CENTER
End Enum

'lokale Variable(n) zum Zuweisen der Eigenschaft(en)
Private mvarCols As Long 'lokale Kopie
'lokale Variable(n) zum Zuweisen der Eigenschaft(en)
Private mvarRows As Long 'lokale Kopie
Private mvarTextMatrix() As String 'lokale Kopie
'Private mvarColFont() As StdFont 'lokale Kopie
Private mvarHeaderText() As String 'lokale Kopie
Private mvarHeaderFont() As StdFont 'lokale Kopie
Private mvarColAlignment() As EAlignment 'lokale Kopie
Private mvarHasFooter As Boolean 'lokale Kopie
Private mvarFooterFont() As StdFont 'lokale Kopie
Private mvarFooterText() As String 'lokale Kopie
Private mvarMarginTop As Single 'lokale Kopie
Private mvarMarginBottom As Single 'lokale Kopie
Private mvarMarginLeft As Single 'lokale Kopie
'Private mvarMarginRight As Single 'lokale Kopie
Private mvarLineThickness As Integer 'lokale Kopie
Private mvarHeaderLineThickness As Integer 'lokale Kopie
Private mvarFooterLineThickness As Integer 'lokale Kopie
Private mvarCellYOffset As Single 'lokale Kopie
Private mvarCellXOffset As Single 'lokale Kopie
Private m_ColWidth() As Single
Private m_MergeCol() As Boolean
Private m_FontMatrix() As StdFont
Private mvarHeaderRows As Long 'lokale Kopie
Private mvarPictureMatrix() As IPictureDisp 'lokale Kopie
Private m_MergeHeaderCol() As Boolean
Private m_MergeHeaderRow() As Boolean
Private m_MergeRow() As Boolean

'Um dieses Ereignis auszul鰏en, verwenden Sie RaiseEvent mit der folgenden Syntax:
'RaiseEvent NewPage[(arg1, arg2, ... , argn)]
Public Event NewPage(objOutput As Object, TopMarginAlreadySet As Boolean, bCancel As Boolean, ByVal lLastPrintedRow As Long)

Public PrintHeaderOnEveryPage As Boolean
Public CenterMergedHeader As Boolean
Public RowHeightMin As Single, HeaderRowHeightMin As Single, FooterRowHeightMin As Single
Public ResizeCellsToPicHeight As Boolean

Function CalcNumRowsPerPage(objOutput As Object, Optional ByVal bWithHeader = True, Optional ByVal bWithFooter)
    Dim sngNormalRowH As Single, sngHeaderRowH As Single, sngFooterRowH As Single
    Dim LastFont As StdFont, sngTmp As Single, lRow As Long, L As Long
    
    If IsMissing(bWithFooter) Then
        bWithFooter = mvarHasFooter
    End If
    
    sngNormalRowH = RowHeightMin - 2 * mvarCellYOffset
    sngHeaderRowH = HeaderRowHeightMin - 2 * mvarCellYOffset
    sngFooterRowH = FooterRowHeightMin - 2 * mvarCellYOffset
    
    For L = 0 To mvarCols - 1
        For lRow = 0 To mvarRows - 1
            If Not (LastFont Is m_FontMatrix(lRow, L)) Then
                Set LastFont = m_FontMatrix(lRow, L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarTextMatrix(lRow, L))
            If sngTmp > sngNormalRowH Then sngNormalRowH = sngTmp
            If ResizeCellsToPicHeight Then
                If Not (mvarPictureMatrix(lRow, L) Is Nothing) Then
                    sngTmp = objOutput.ScaleY(mvarPictureMatrix(lRow, L).Height, vbHimetric, objOutput.ScaleMode)
                    If sngTmp > sngNormalRowH Then sngNormalRowH = sngTmp
                End If
            End If
        Next
        For lRow = 0 To mvarHeaderRows - 1
            If Not (LastFont Is mvarHeaderFont(lRow, L)) Then
                Set LastFont = mvarHeaderFont(lRow, L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarHeaderText(lRow, L))
            If sngTmp > sngHeaderRowH Then sngHeaderRowH = sngTmp
        Next
        If mvarHasFooter Then
            If Not (LastFont Is mvarFooterFont(L)) Then
                Set LastFont = mvarFooterFont(L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarFooterText(L))
            If sngTmp > sngFooterRowH Then sngFooterRowH = sngTmp
        End If
    Next
    
    sngNormalRowH = sngNormalRowH + 2 * mvarCellYOffset
    sngHeaderRowH = sngHeaderRowH + 2 * mvarCellYOffset
    If sngFooterRowH > 0 Then sngFooterRowH = sngFooterRowH + 2 * mvarCellYOffset
    
    sngTmp = (objOutput.ScaleHeight - mvarMarginBottom - mvarMarginTop)
    'CalcNumRowsPerPage = Int((objOutput.ScaleHeight - sngHeaderRowH - sngFooterRowH - mvarMarginBottom - mvarMarginTop) / sngNormalRowH)
    If bWithHeader Then
        'CalcNumRowsPerPage = CalcNumRowsPerPage + 1
        sngTmp = sngTmp - sngHeaderRowH * mvarHeaderRows
    End If
    If bWithFooter Then
        'CalcNumRowsPerPage = CalcNumRowsPerPage + 1
        sngTmp = sngTmp - sngFooterRowH
    End If
    CalcNumRowsPerPage = Int(sngTmp / sngNormalRowH)
End Function

Private Sub pDoVCenter(ByVal hDC As Long, rcDraw As RECT, sText As String)
    Dim rcTmp As RECT, lRet As Long
    lRet = DrawText(hDC, sText, -1, rcTmp, c_DTDefFmt Or DT_CALCRECT)
    rcDraw.Top = (rcDraw.Bottom - rcDraw.Top - lRet) \ 2 + rcDraw.Top
End Sub


Public Property Set PictureMatrix(ByVal Row As Long, ByVal Col As Long, ByVal vData As IPictureDisp)
    Dim L As Long, L2 As Long
    If (Row < 0) And (Col < 0) Then
        For L = 0 To mvarRows - 1
            For L2 = 0 To mvarCols - 1
                Set mvarPictureMatrix(L, L2) = vData
            Next
        Next
    ElseIf (Row < 0) Then
        For L = 0 To mvarRows - 1
            Set mvarPictureMatrix(L, Col) = vData
        Next
    ElseIf (Col < 0) Then
        For L = 0 To mvarCols - 1
            Set mvarPictureMatrix(Row, L) = vData
        Next
    Else
        Set mvarPictureMatrix(Row, Col) = vData
    End If

End Property


Public Property Get PictureMatrix(ByVal Row As Long, ByVal Col As Long) As IPictureDisp
'wird beim Ermitteln einer Eignschaft auf der rechten Seite der Gleichung verwendet.
'Syntax: Debug.Print X.PictureMatrix
    Set PictureMatrix = mvarPictureMatrix(Row, Col)
End Property



Public Property Let HeaderRows(ByVal vData As Long)
'wird beim Zuweisen eines Werts in eine Eigenschaft auf der linken Seite der Gleichung, verwendet.
'Syntax: X.HeaderRows = 5
    If vData < 1 Then
        Err.Raise 380
    End If
    mvarHeaderRows = vData
    pRedimArrays
End Property


Public Property Get HeaderRows() As Long
'wird beim Ermitteln einer Eignschaft auf der rechten Seite der Gleichung verwendet.
'Syntax: Debug.Print X.HeaderRows
    HeaderRows = mvarHeaderRows
End Property



Public Sub DrawTable(objOutput As Object, Optional lRowToStart As Long = 0, Optional lStartPage As Long = 1)
    Dim rctDraw As RECT, LastRow As Long, PgNum As Long
    Dim sngNormalRowH As Single, sngHeaderRowH As Single, sngFooterRowH As Single
    Dim sngSW As Single, L As Long, sngTmp As Single, bFlag As Boolean
    Dim sngYStart As Single, iSM As Integer, lArrCW() As Long, lMargPix As Long
    Dim lRow As Long, lRH As Long, StartRow As Long, LastTop As Single
    Dim lPixXOffset As Long, OldFont As StdFont, bMerged() As Boolean, LastFont As StdFont
    Dim picCoords(1 To 4) As Single, lPixYOffset As Long, lTmp As Long
    Dim lHeaderMergeRow() As Long, bHeaderFlag() As Boolean
    
    'sngSW = objOutput.ScaleWidth - mvarMarginRight
    
    Set OldFont = objOutput.Font
    Set LastFont = OldFont
    ReDim lArrCW(0 To mvarCols - 1)
    ReDim lHeaderMergeRow(0 To mvarCols - 1) ' Below again (Loop)
    ReDim bHeaderFlag(0 To mvarHeaderRows - 1)
    ReDim bMerged(0 To mvarHeaderRows - 1)
    
    iSM = objOutput.ScaleMode
    sngSW = mvarMarginLeft
    
    sngNormalRowH = RowHeightMin - 2 * mvarCellYOffset
    sngHeaderRowH = HeaderRowHeightMin - 2 * mvarCellYOffset
    sngFooterRowH = FooterRowHeightMin - 2 * mvarCellYOffset
    
    For L = 0 To mvarCols - 1
        For lRow = 0 To mvarRows - 1
            If Not (LastFont Is m_FontMatrix(lRow, L)) Then
                Set LastFont = m_FontMatrix(lRow, L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarTextMatrix(lRow, L))
            If sngTmp > sngNormalRowH Then sngNormalRowH = sngTmp
            If ResizeCellsToPicHeight Then
                If Not (mvarPictureMatrix(lRow, L) Is Nothing) Then
                    sngTmp = objOutput.ScaleY(mvarPictureMatrix(lRow, L).Height, vbHimetric, iSM)
                    If sngTmp > sngNormalRowH Then sngNormalRowH = sngTmp
                End If
            End If
        Next
        For lRow = 0 To mvarHeaderRows - 1
            If Not (LastFont Is mvarHeaderFont(lRow, L)) Then
                Set LastFont = mvarHeaderFont(lRow, L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarHeaderText(lRow, L))
            If sngTmp > sngHeaderRowH Then sngHeaderRowH = sngTmp
        Next
        If mvarHasFooter Then
            If Not (LastFont Is mvarFooterFont(L)) Then
                Set LastFont = mvarFooterFont(L)
                Set objOutput.Font = LastFont
            End If
            sngTmp = objOutput.TextHeight(mvarFooterText(L))
            If sngTmp > sngFooterRowH Then sngFooterRowH = sngTmp
        End If
        sngSW = sngSW + m_ColWidth(L)
        lArrCW(L) = objOutput.ScaleX(m_ColWidth(L), iSM, vbPixels)
        lHeaderMergeRow(L) = -1
    Next
    lMargPix = objOutput.ScaleX(mvarMarginLeft, iSM, vbPixels)
    lPixXOffset = objOutput.ScaleX(mvarCellXOffset, iSM, vbPixels)
    lPixYOffset = objOutput.ScaleY(mvarCellYOffset, iSM, vbPixels)
    
    sngNormalRowH = sngNormalRowH + 2 * mvarCellYOffset
    sngHeaderRowH = sngHeaderRowH + 2 * mvarCellYOffset
    If sngFooterRowH > 0 Then sngFooterRowH = sngFooterRowH + 2 * mvarCellYOffset
    
    'objOutput.CurrentX = mvarMarginLeft
    objOutput.FillStyle = vbFSTransparent
    PgNum = lStartPage
    LastRow = lRowToStart - 1
    Do
        sngTmp = 0
        sngTmp = (objOutput.ScaleHeight - objOutput.CurrentY - mvarMarginBottom)
        'L = Int((objOutput.ScaleHeight - objOutput.CurrentY - sngHeaderRowH - sngFooterRowH - mvarMarginBottom) / sngNormalRowH)
        If sngTmp >= sngNormalRowH Then

            If LastRow >= mvarRows Then
                'LastRow = LastRow + 1 'We don't need the footer !
                sngTmp = sngTmp - sngFooterRowH
            End If
            If PrintHeaderOnEveryPage Or (PgNum > 1) Then
                'LastRow = LastRow + 1
                sngTmp = sngTmp - sngHeaderRowH * mvarHeaderRows
            End If
            StartRow = LastRow + 1
            L = Int(sngTmp / sngNormalRowH)
            LastRow = LastRow + L
            If LastRow > mvarRows - 1 Then
                LastRow = mvarRows - 1
            End If
            
            sngYStart = objOutput.CurrentY
            LastTop = sngYStart
            If PrintHeaderOnEveryPage Or (PgNum = 1) Then
                objOutput.DrawWidth = mvarHeaderLineThickness
                For lRow = 0 To mvarHeaderRows - 1
'                    rctDraw.Bottom = rctDraw.Bottom + objOutput.ScaleY(sngHeaderRowH, iSM, vbPixels)
                    'objOutput.Line (mvarMarginLeft, sngYStart + lRow * sngHeaderRowH)-(sngSW, sngYStart + sngHeaderRowH * (lRow + 1)), , B
                    'objOutput.Line (mvarMarginLeft, sngYStart + sngHeaderRowH)-(sngSW, sngYStart )
'                    rctDraw.Top = objOutput.ScaleY(sngYStart + lRow * sngHeaderRowH, iSM, vbPixels)
                    rctDraw.Left = lMargPix + lPixXOffset
                    rctDraw.Right = lMargPix - lPixXOffset
                    sngTmp = mvarMarginLeft
                    bHeaderFlag(lRow) = False
                    bMerged(lRow) = False
                    For L = 0 To mvarCols - 1
                        If m_MergeHeaderCol(L) Then
                            If lRow < mvarHeaderRows - 1 Then
                                If mvarHeaderText(lRow, L) = mvarHeaderText(lRow + 1, L) Then
                                    bFlag = False
                                    If lHeaderMergeRow(L) = -1 Then lHeaderMergeRow(L) = lRow
                                Else
                                    bFlag = True
                                End If
                            Else
                                bFlag = True
                            End If
                        Else