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 = False
Attribute VB_Ext_KEY = "SavedWithClassBuilder6" ,"Yes"
Attribute VB_Ext_KEY = "Top_Level" ,"Yes"
Option Explicit
'**************************************************************
'*類模塊名稱：clsColHeader
'*類模塊說明：報表的列頭對象
'*備注：
'*
'*作者：progame
'*日期：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          '*實際跨行數(shù)

Private cutpage()       As typeCutPage

Friend Function GetMergeCells() As Dictionary
'*對于內(nèi)部提供合并單元格集合
    Set GetMergeCells = dicMergeCell
End Function

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

Public Property Get rows() As Integer
'*得到行數(shù)
    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
'*得到總分頁數(shù)
    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
'*功能：設(shè)置列數(shù)和行數(shù)
'*傳入?yún)?shù)：
'*      cols        --列數(shù)
'*      rows        --行數(shù)
'*返回參數(shù)：
'*      設(shè)置是否成功
'*作者：progame
'*日期：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
'*功能：設(shè)置一個單元格的值
'*傳入?yún)?shù)：
'*      col     --列
'*      row     --行
'*      cell    --單元
'*返回參數(shù)：
'*
'*作者：progame
'*日期：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
'*功能：得到分頁信息
'*傳入?yún)?shù)：
'*      uWidth          --可用頁寬度
'*作者：progame
'*日期：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
'*功能：合并單元格，需要知道的參數(shù)所有列頭單元對象
'*傳入?yún)?shù)：
'*      uWidth          --可用頁寬
'*返回參數(shù)：
'*
'*作者：progame
'*日期：2002-03-22 21:18:38
'***************************************************************
Public Sub Merge(uWidth As Single)

Dim bRow        As Boolean          '*當(dāng)前為加行的判斷
Dim mergeCell   As clsCell          '*新的合并單元

'*從第一個單元格開始，在第一分頁內(nèi)查找要合并的單元格
Dim page        As Integer
Dim bNoWay      As Integer          '*在尋求合并單元格的時候，橫向和豎向都無法找到
Dim bSame       As Boolean          '*是否此矩形框內(nèi)的單元格全部相同
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
    
    '*初始化處理標(biāo)志
    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   '*如果未被處理過，則開始處理
                    '*以當(dāng)前單元格為基準(zhǔn)，每次先加一行，再加一列。。。。
                    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
                    
                    '*加上處理標(biāo)志
                    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
    
    
    '*得到實際分行數(shù)
    CalRows
End Sub


'**************************************************************
'*名稱：IfSame
'*功能：是否需要合并的單元格
'*傳入?yún)?shù)：
'*
'*作者：progame
'*日期：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
        
            '*如果此單元格已經(jīng)被處理過或者和對比單元格內(nèi)容不一樣，則不可合并
            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
'*功能：得到列頭的跨行數(shù)
'*傳入?yún)?shù)：
'*
'*返回參數(shù)：
'*
'*作者：progame
'*日期：2002-03-25 14:56:31
'***************************************************************
Private Sub CalRows()
'*得到實際上新單元格的跨行數(shù)
    '*將所有終止行為當(dāng)前行的新單元格找到，然后取最大的跨行數(shù)
    '*下面的終止行必須至少比上一個終止行的實際跨行數(shù)加上1
    
Dim i                   As Integer
Dim j                   As Integer
Dim mergeCell
Dim SpanRows(0 To 10)   As Integer          '*列頭的行實際跨行數(shù)
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        '*終止行為當(dāng)前行
                
                    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
'*功能：輸出列頭
'*傳入?yún)?shù)：
'*      obj     --要輸出的對象
'*      page    --分頁數(shù)
'*      left    --列頭輸出的左起點
'*      top     --列頭輸出的頂起點
'*      sRate   --縮放比例
'*返回參數(shù)：
'*
'*作者：progame
'*日期：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

        '*繪制整個區(qū)域的左邊框和頂部邊框
        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
        
            '*找到當(dāng)前分頁的單元格，并重新指定高度輸出
            If .cutpage = cutpage Then
                .text.left = left + .text.left
                .text.Top = Top + .text.Top

                .text.PrintIt obj, sRate
                
                '*恢復(fù)設(shè)置
                .text.left = .text.left - left
                .text.Top = .text.Top - Top
            End If
            
        End With
        
    Next i
    
End Function


'**************************************************************
'*名稱：GetWidth
'*功能：得到分頁的寬度
'*傳入?yún)?shù)：
'*      cutpage         --分頁
'*返回參數(shù)：
'*      此分頁的正文輸出寬度
'*作者：progame
'*日期：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
    
'*釋放數(shù)組
    Erase cells
    Erase cutpage
End Sub