clscolheader.cls

超经典的打印预览动态库源码 版权： 本资源版权归作者所有 说明： 本资源由源码天空搜集,仅提供学习参考

VERSION 1.0 CLASS
BEGIN
  MultiUse = -1  'True
  Persistable = 0  'NotPersistable
  DataBindingBehavior = 0  'vbNone
  DataSourceBehavior  = 0  'vbNone
  MTSTransactionMode  = 0  'NotAnMTSObject
END
Attribute VB_Name = "clsColHeader"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"

Option Explicit
'**************************************************************
'*类模块名称：clsColHeader
'*类模块说明：报表的列头对象
'*备注：
'*
'*作者：chlf78
'*日期：2002-03-22 21:16:07
'***************************************************************

Private Const ModalName = "clsColHeader"


Private Type typeCutPage
    colFrom     As Integer
    colTo       As Integer
End Type

'*存放合并后的单元
Private dicMergeCell    As Dictionary

'*存放初始的单元格
Private cells()         As clsCell

Private m_cols          As Integer
Private m_rows          As Integer

Private m_spanrows      As Integer          '*实际跨行数

Private cutpage()       As typeCutPage

Friend Function GetMergeCells() As Dictionary
'*对于内部提供合并单元格集合
    Set GetMergeCells = dicMergeCell
End Function

Public Property Get Cols() As Integer
'*得到列数
    Cols = m_cols
End Property

Public Property Get rows() As Integer
'*得到行数
    rows = m_rows
End Property

Public Function GetHeight() As Single
'*得到高度
    GetHeight = m_spanrows * cells(m_cols, m_rows).text.rowheight
End Function

Public Property Get cutpages() As Integer
'*得到总分页数
    cutpages = cells(m_cols, m_rows).cutpage
End Property

Public Function GetText(col As Integer, row As Integer) As clsText
'*取得列头单元格中的字符串对象
    If m_rows = 0 Or m_cols = 0 Then
        Set GetText = Nothing
    End If
    
    Set GetText = cells(col, row).text
    
End Function

'**************************************************************
'*名称：SetColRows
'*功能：设置列数和行数
'*传入参数：
'*      cols        --列数
'*      rows        --行数
'*返回参数：
'*      设置是否成功
'*作者：chlf78
'*日期：2002-03-27 16:08:34
'***************************************************************
Public Function SetColRows(Cols As Integer, rows As Integer) As Boolean

    If Cols < 1 Or rows < 1 Or rows > 10 Then
        SetColRows = False
    End If
    
On Error GoTo err_proc

    ReDim Preserve cells(1 To Cols, 1 To rows)
    
    m_cols = Cols
    m_rows = rows
    
    SetColRows = True
    Exit Function
    
err_proc:
    SetColRows = False
End Function


'**************************************************************
'*名称：SetCell
'*功能：设置一个单元格的值
'*传入参数：
'*      col     --列
'*      row     --行
'*      cell    --单元
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-27 16:15:00
'***************************************************************
Public Function SetCell(cell As clsCell) As Boolean
    
    On Error GoTo err_proc
    
    Set cells(cell.colFrom, cell.rowFrom) = cell
    
    SetCell = True
    Exit Function
    
'*错误处理
err_proc:
    SetCell = False
End Function

'**************************************************************
'*名称：GetCutPage
'*功能：得到分页信息
'*传入参数：
'*      uWidth          --可用页宽度
'*作者：chlf78
'*日期：2002-03-27 16:39:08
'***************************************************************
Private Sub GetCutPage(uWidth As Single)
Dim i               As Integer
Dim j               As Integer
Dim lstCutPage      As Integer
Dim sWidth          As Single
Dim cp              As Integer

    cp = 1
    sWidth = 0
    For i = 1 To m_cols
        sWidth = sWidth + cells(i, m_rows).text.width
        If sWidth > uWidth And i <> 1 Then
            cp = cp + 1
            sWidth = cells(i, m_rows).text.width
        End If
        For j = 1 To m_rows
            cells(i, j).cutpage = cp
            cells(i, j).text.left = sWidth - cells(i, j).text.width
        Next j
    Next i
    
    ReDim cutpage(1 To cp)
    '*先得到每个分页的列起止
    lstCutPage = 0
    
    For i = 1 To m_cols
        j = cells(i, m_rows).cutpage
        
        If j <> lstCutPage Then
            cutpage(j).colFrom = i
        End If
        
        cutpage(j).colTo = i
        lstCutPage = j
    Next i
    
End Sub

'**************************************************************
'*名称：Merge
'*功能：合并单元格，需要知道的参数所有列头单元对象
'*传入参数：
'*      uWidth          --可用页宽
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-22 21:18:38
'***************************************************************
Public Sub Merge(uWidth As Single)

Dim bRow        As Boolean          '*当前为加行的判断
Dim mergeCell   As clsCell          '*新的合并单元

'*从第一个单元格开始，在第一分页内查找要合并的单元格
Dim page        As Integer
Dim bNoWay      As Integer          '*在寻求合并单元格的时候，横向和竖向都无法找到
Dim bSame       As Boolean          '*是否此矩形框内的单元格全部相同
Dim colWidth    As Single           '*多个合并单元格的列宽

Dim i As Integer, j As Integer, k As Integer, l As Integer, m As Integer, n As Integer

    '*先清空合并单元格存放对象
    dicMergeCell.RemoveAll
    
    '*初始化处理标志
    For i = 1 To m_cols
        For j = 1 To m_rows
            cells(i, j).bDone = False
        Next j
    Next i
    
    GetCutPage uWidth                   '*得到分页信息
    
    For page = 1 To UBound(cutpage)    '*从第一分页到最后一个单元格所在的分页
        
        For i = cutpage(page).colFrom To cutpage(page).colTo
            
            For j = 1 To m_rows
            
                If Not cells(i, j).bDone Then   '*如果未被处理过，则开始处理
                    '*以当前单元格为基准，每次先加一行，再加一列。。。。
                    bRow = True
                    k = i
                    l = j
                    colWidth = cells(i, j).text.width
                    
                    Do While IfSame(cells, cutpage(page).colTo, m_rows, i, j, k + 1, l) Or _
                        IfSame(cells, cutpage(page).colTo, m_rows, i, j, k, l + 1)
                        If IfSame(cells, cutpage(page).colTo, m_rows, i, j, k + 1, l) Then
                            colWidth = colWidth + cells(k + 1, l).text.width
                            k = k + 1
                        Else
                            l = l + 1
                        End If
                    Loop

                    '*将此合并单元存储起来
                    Set mergeCell = New clsCell
                    
                    With mergeCell
                        .cutpage = cells(i, j).cutpage
                        .colFrom = i
                        .rowFrom = j
                        .colTo = k
                        .rowTo = l
                        cells(i, j).text.Clone .text
                        .text.width = colWidth
                        .rows = cells(i, j).text.GetRows
                    End With
                    
                    dicMergeCell.Add dicMergeCell.Count + 1, mergeCell
                    
                    Set mergeCell = Nothing
                    
                    '*加上处理标志
                    For m = i To k
                        For n = j To l
                            cells(m, n).bDone = True
                        Next n
                    Next m
                    
                End If
                
            Next j
            
        Next i
        
    Next page
    
    
    '*得到实际分行数
    CalRows
End Sub


'**************************************************************
'*名称：IfSame
'*功能：是否需要合并的单元格
'*传入参数：
'*
'*作者：chlf78
'*日期：2002-03-22 22:10:16
'***************************************************************
Private Function IfSame(ByRef cells, _
                        colTo As Integer, rowTo As Integer, _
                        col As Integer, row As Integer, _
                        k As Integer, l As Integer) _
    As Boolean
                        
    If k > colTo Or l > rowTo Then
        IfSame = False
        Exit Function
    End If
    
Dim i           As Integer
Dim j           As Integer
Dim str         As String

    IfSame = True
    str = cells(col, row).text.stringX
    
    For i = col To k
    
        For j = row To l
        
            '*如果此单元格已经被处理过或者和对比单元格内容不一样，则不可合并
            If cells(i, j).text.stringX <> str _
                Or cells(i, j).bDone Then
                IfSame = False
                Exit Function
            End If
            
        Next j
        
    Next i
    
    
End Function


'**************************************************************
'*名称：GalRows
'*功能：得到列头的跨行数
'*传入参数：
'*
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-25 14:56:31
'***************************************************************
Private Sub CalRows()
'*得到实际上新单元格的跨行数
    '*将所有终止行为当前行的新单元格找到，然后取最大的跨行数
    '*下面的终止行必须至少比上一个终止行的实际跨行数加上1
    
Dim i                   As Integer
Dim j                   As Integer
Dim mergeCell
Dim SpanRows(0 To 10)   As Integer          '*列头的行实际跨行数
Dim maxSpanRows         As Integer

    maxSpanRows = 0
    SpanRows(0) = 0
    
    For i = 1 To m_rows
    
        maxSpanRows = maxSpanRows + 1
        
        For j = 1 To dicMergeCell.Count
            Set mergeCell = dicMergeCell.item(j)
            
            With mergeCell
                If .rowTo = i Then        '*终止行为当前行
                
                    If maxSpanRows < SpanRows(.rowFrom - 1) + .rows Then
                        maxSpanRows = SpanRows(.rowFrom - 1) + .rows
                    End If
                    
                End If
            End With
        Next j
        
        SpanRows(i) = maxSpanRows
        
    Next i
    
    '*重新定义新单元格的输出行起始和终止
    For Each mergeCell In dicMergeCell.Items
    
        With mergeCell
            .fRowFrom = SpanRows(.rowFrom - 1) + 1
            .fRowTo = SpanRows(.rowTo)
            .text.Top = (.fRowFrom - 1) * .text.rowheight
            .text.height = (.fRowTo - .fRowFrom + 1) * .text.rowheight
        End With
        
    Next
    
    m_spanrows = maxSpanRows
    
End Sub


'**************************************************************
'*名称：PrintIt
'*功能：输出列头
'*传入参数：
'*      obj     --要输出的对象
'*      page    --分页数
'*      left    --列头输出的左起点
'*      top     --列头输出的顶起点
'*      sRate   --缩放比例
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-03-26 16:27:51
'***************************************************************
Public Function PrintIt(obj As Object, cutpage As Integer, _
                        left As Single, Top As Single, sRate As Single)

Dim i           As Integer
Dim mergeCell   As clsCell
Dim ForeColor   As OLE_COLOR

    On Error Resume Next
    
    If dicMergeCell.Count > 0 Then
        '*得到线宽和颜色
        obj.DrawWidth = IIf(sRate < 1, 1, CInt(sRate))
        ForeColor = vbBlack

        '*绘制整个区域的左边框和顶部边框
        obj.Line (left * sRate, Top * sRate)-Step(GetWidth(cutpage) * sRate, 0), ForeColor
        obj.Line (left * sRate, Top * sRate)-Step(0, GetHeight * sRate), ForeColor
    End If
    
    For i = 1 To dicMergeCell.Count
    
        Set mergeCell = dicMergeCell.item(i)
        
        With mergeCell
        
            '*找到当前分页的单元格，并重新指定高度输出
            If .cutpage = cutpage Then
                .text.left = left + .text.left
                .text.Top = Top + .text.Top

                .text.PrintIt obj, sRate
                
                '*恢复设置
                .text.left = .text.left - left
                .text.Top = .text.Top - Top
            End If
            
        End With
        
    Next i
    
End Function


'**************************************************************
'*名称：GetWidth
'*功能：得到分页的宽度
'*传入参数：
'*      cutpage         --分页
'*返回参数：
'*      此分页的正文输出宽度
'*作者：chlf78
'*日期：2002-04-05 15:26:38
'***************************************************************
Public Function GetWidth(cutpage As Integer) As Single
Dim mergeCell

    GetWidth = 0
    
    For Each mergeCell In dicMergeCell.Items
        With mergeCell
            If .rowFrom = 1 And .cutpage = cutpage Then
                GetWidth = GetWidth + .text.width
            End If
        End With
    Next
    
End Function

Private Sub Class_Initialize()
    Set dicMergeCell = New Dictionary
End Sub

Private Sub Class_Terminate()
'*清空对象
    Set dicMergeCell = Nothing
    
'*释放数组
    Erase cells
    Erase cutpage
End Sub