clscontentnew.cls

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

End Function

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

    cp = 1
    sWidth = 0
    For i = 1 To m_cols
    
        sWidth = sWidth + colText(i).width
        
        If sWidth > uWidth And i <> 1 Then
            cp = cp + 1
            sWidth = colText(i).width
        End If
        
        colText(i).tag = cp
        colText(i).left = sWidth - colText(i).width
        
    Next i

    
End Sub

'**************************************************************
'*名称：Merge
'*功能：合并单元格
'*传入参数：
'*      pageWidth       --可用的页宽度
'*      pageHeight      --可用的面高度
'*      firstPageHeight --第一页的可用高度
'*      latPageHeight   --最后一页的可用高度
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-04-20 22:25:25
'***************************************************************
Public Sub Merge(pagewidth As Single, _
                 pageheight As Single, _
                 firstPageHeight As Single, _
                 lastPageHeight As Single)
'*合并单元格
Dim page            As Integer
Dim row             As Integer
Dim bRowLeft        As Boolean          '*是否有行剩下
Dim i               As Integer

    '*首先重新得到分页信息
    GetCutPage pagewidth
    
    ReDim dicCurPage(1 To m_cols)
    
    For i = 1 To m_cols
        Set dicCurPage(i) = New Dictionary
        colHeight(i) = 0
    Next i
    
    Set dicMergeCell = Nothing
    Set dicPageHeight = Nothing
    Set dicMergeCell = New Dictionary
    Set dicPageHeight = New Dictionary
    
    page = 0
    
    For row = 1 To m_rows
        bRowLeft = True
        '*在当前页的所有单元格中加入此行
        AddRow row
        
        '*判断是否超出高度(如果超出，存储已经确定的单元格，并清空当前页，新开页）
        If OutHeight(page, row, pageheight, firstPageHeight, lastPageHeight) Then
        
            If row <> 1 Then        '*如果是第一行，不移除
                RemoveRow row
            End If
            
            '*保存当前页的单元格，并清空当前页
            page = page + 1
            SavePage page
            bRowLeft = False
            
            '*再次增加此行
            AddRow row

        End If
        
        'DoEvents
        RaiseEvent InitProgress(row / m_rows * 100)
        
    Next row
    
    '*最后如果有多出来的行，增加页
    If bRowLeft Then
        page = page + 1
        SavePage page
    End If
    
    
    '*将合并后的单元格充入到二维数组
    FillCell
    
    '*释放对象
    Set dicMergeCell = Nothing
    
    '*释放数组
    Erase dicCurPage
    
End Sub

Private Sub AddRow(row As Integer)
'*在当前页的集合中添加一行row

Dim cell            As clsCellNew
Dim mergeCell       As clsCellNew
Dim col             As Integer
Dim cText           As clsText

    For col = 1 To m_cols
        lstColHeight(col) = colHeight(col)
        Set cell = cells(col, row)
        
        If IfMerge(col, row) Then       '*是否需要合并
            dicCurPage(col).item(dicCurPage(col).Count).rowTo = dicCurPage(col).item(dicCurPage(col).Count).rowTo + 1
        Else                            '*如果不要合并
            '*添加一个新的单元格
            Set mergeCell = New clsCellNew
            
            With mergeCell
                .colFrom = col
                .rowFrom = row
                .rowTo = row
                .stringX = cell.stringX
                .Top = lstColHeight(col)
                colText(col).stringX = .stringX
                .height = colText(col).GetRows * colText(col).rowheight
            End With
            
            '*增加了一个单元格，colheight增加
            colHeight(col) = colHeight(col) + mergeCell.height
            
            dicCurPage(col).Add dicCurPage(col).Count + 1, mergeCell
            
            Set mergeCell = Nothing
            
        End If
    Next col
    
    '*计算新的高度
    Dim maxHeight   As Single
    
    For col = 1 To m_cols
    
        If colHeight(col) > maxHeight Then
            maxHeight = colHeight(col)
        End If
        
    Next col
    
    '*重新设定最后一个单元格的高度差(为maxHeight - colHeight(col))
    For col = 1 To m_cols
    
        dicCurPage(col).item(dicCurPage(col).Count).height = _
            dicCurPage(col).item(dicCurPage(col).Count).height _
            + (maxHeight - colHeight(col))

        '*将colheight统一到maxHeight
        colHeight(col) = maxHeight
        
    Next col
End Sub

Private Sub RemoveRow(row As Integer)
'*移除一行
Dim col         As Integer
    
    For col = 1 To m_cols
    
        If IfMerge(col, row) Then
            '*将最后一个单元格重新设定高度
            dicCurPage(col).item(dicCurPage(col).Count).height = _
                dicCurPage(col).item(dicCurPage(col).Count).height _
                - (colHeight(col) - lstColHeight(col))
        Else
            '*移除当前页的最后一个单元格
            dicCurPage(col).Remove dicCurPage(col).Count
        End If
        
        colHeight(col) = lstColHeight(col)
        
    Next col
    

End Sub

Private Sub SavePage(page As Integer)
'*存储当前页，并清空

Dim col         As Integer
Dim cell
       
    '*保存当前页的正文高度
    dicPageHeight.Add page, colHeight(m_cols)
    
    For col = 1 To m_cols
    
        For Each cell In dicCurPage(col).Items
        
            With cell
                .page = page
            End With
            
            dicMergeCell.Add dicMergeCell.Count + 1, cell
            
        Next
        
        dicCurPage(col).RemoveAll
        lstColHeight(col) = 0
        colHeight(col) = 0
        
    Next col
    
End Sub

Private Function IfMerge(col As Integer, row As Integer) As Boolean
'*是否需要合并

    '*如果此列不需要合并，直接返回
    If Not mergeCol(col) Then
        IfMerge = False
        Exit Function
    End If
    
    '*如果当前页的此列没有单元格，说明是第一个单元格，所以不要合并
    If dicCurPage(col).Count = 0 Then
        IfMerge = False
        Exit Function
    End If
    
    '*如果和上一个单元格的内容不同，则不需要合并
    If cells(col, row - 1).stringX _
        <> cells(col, row).stringX Then
        IfMerge = False
    Else
        IfMerge = True
    End If
    
End Function

Private Sub FillCell()
'*将合并后的单元格充入到二维数组

Dim cell

    '*重新定义数组
    Dim pages       As Integer
    Dim cutpages    As Integer
    
    Set cell = dicMergeCell.item(dicMergeCell.Count)
    pages = cell.page
    cutpages = colText(m_cols).tag
    
    ReDim dicCell(1 To pages, 1 To cutpages)
    
    Dim i As Integer, j As Integer
    
    For i = 1 To pages
    
        For j = 1 To cutpages
            Set dicCell(i, j) = New Dictionary
        Next j
        
    Next i
    
    '*填充
    For Each cell In dicMergeCell.Items
        page = cell.page
        cutpage = colText(cell.colFrom).tag
        
        dicCell(page, cutpage).Add dicCell(page, cutpage).Count + 1, cell
    Next
    
End Sub

Private Function OutHeight(page As Integer, row As Integer, _
                           ByRef pageheight As Single, _
                           ByRef firstPageHeight As Single, _
                           ByRef lastPageHeight As Single) As Boolean
'*是否超出了页宽
Dim mPageHeight     As Single

    If page + 1 = 1 Then
        mPageHeight = firstPageHeight
    Else
        mPageHeight = pageheight
    End If

    If colHeight(m_cols) > mPageHeight Then
        OutHeight = True
        Exit Function
    End If

    '*如果是最后一条记录
    If row = m_rows Then
        If colHeight(m_cols) > mPageHeight - (lastPageHeight - pageheight) Then
            OutHeight = True
            Exit Function
        End If
    End If
    
    OutHeight = False
End Function

Private Sub Class_Terminate()
'*释放对象
    Set dicMergeCell = Nothing
    Set dicPageHeight = Nothing
    
'*释放数组
    Erase dicCurPage
    Erase cells
    Erase colHeight
    Erase lstColHeight
    Erase dicCell
End Sub