clscontentnew.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 = "clsContent"
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
'**************************************************************
'*类模块名称：clsContent
'*类模块说明：报表的正文对象
'*
'*备注：
'*      存入的单元格cell对象应该都已经知道了分页属性
'*      开始存入的单元格并不具备分行等特性
'*      所有和正文相关的操作都由本对象提供
'*
'*      所有涉及到行列的数组，列在前面，行在后面
'*作者：chlf78
'*日期：2002-04-01 19:55:41
'***************************************************************


Public page             As Integer              '*页
Public cutpage          As Integer              '*分页

Private dicMergeCell    As Dictionary           '*合并单元格
Private dicCell()       As Dictionary           '*按页和分页来存放合并单元格
Private colText()       As clsText              '*列的属性设置

Private dicCurPage()    As Dictionary           '*当前页的合并单元格存放

Private m_cols          As Integer              '*列数
Private m_rows          As Integer              '*行数
Private m_cutpages      As Integer              '*分页总数

Private mergeCol()      As Boolean              '*合并列

Private cells()         As clsCellNew           '*单元格数组

Private colHeight()     As Single               '*存入当前页某列的累计高度
Private lstColHeight()  As Single               '*存入当前页某列的未加入当前行的累计高度

Private dicPageHeight   As Dictionary           '*存入页的正文高度

'*分页完成进度
Public Event InitProgress(Value As Integer)

'*打印输出的完成进度
Public Event PrintProgress(Value As Integer)

Friend Function GetMergeCell(page As Integer, cutpage As Integer) As Dictionary
'*对于内部提供合并单元格集合
    Set GetMergeCell = dicCell(page, cutpage)
End Function

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

Public Function GetColText(col As Integer) As clsText
'*取得列设置
    If m_rows = 0 Or m_cols = 0 Then
        Set GetColText = Nothing
    End If
    
    Set GetColText = colText(col)
    
End Function

Public Function GetMergeCol(col As Integer) As Boolean
'*取得此列是否合并
    On Error Resume Next
    
    GetMergeCol = False
    GetMergeCol = mergeCol(col)
    
End Function

Public Property Get Cols() As Integer

    Cols = m_cols
    
End Property

Public Property Get rows() As Integer

    rows = m_rows
    
End Property

'**************************************************************
'*名称：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 Then
        SetColRows = False
    End If
    
On Error GoTo err_proc

    ReDim Preserve cells(1 To Cols, 1 To rows)
    ReDim Preserve mergeCol(1 To Cols)
    ReDim Preserve colText(1 To Cols)
    
    ReDim colHeight(1 To Cols)
    ReDim lstColHeight(1 To Cols)
    
    m_cols = Cols
    m_rows = rows
    m_cutpages = cells(m_cols, m_rows).cutpage
    
    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 clsCellNew) As Boolean
    
    On Error GoTo err_proc
    
    Set cells(cell.colFrom, cell.rowFrom) = cell
    
    SetCell = True
    Exit Function
    
'*错误处理
err_proc:
    SetCell = False
    
End Function


'**************************************************************
'*名称：SetColText
'*功能：设置列的属性
'*传入参数：
'*      col         --列
'*      text        --列设置
'*返回参数：
'*
'*作者：chlf78
'*日期：2002-04-19 10:09:21
'***************************************************************
Public Function SetColText(col As Integer, text As clsText) As Boolean

    On Error GoTo err_proc
    
    Set colText(col) = text
    
    SetColText = True
    Exit Function
    
'*错误处理
err_proc:
    SetColText = False
    
End Function



'**************************************************************
'*名称：SetMergeCol
'*功能：设置要合并的列
'*传入参数：
'*      col     --列值
'*      ifmerge --是否需要合并
'*返回参数：
'*      设置是否成功
'*作者：chlf78
'*日期：2002-03-27 22:54:58
'***************************************************************
Public Function SetMergeCol(col As Integer, IfMerge As Boolean) As Boolean

    If col < 1 Or col > m_cols Then
        SetMergeCol = False
        Exit Function
    End If
    
    '*设置
    mergeCol(col) = IfMerge
    SetMergeCol = True
    
End Function

Public Function GetPages() As Integer
'*得到总页数
    GetPages = dicPageHeight.Count
End Function

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

    On Error Resume Next
    
    GetWidth = 0
    
    For Each cell In dicCell(1, cutpage).Items
        With cell
            If .rowFrom = 1 Then
                GetWidth = GetWidth + .text.width
            End If
        End With
    Next
    
End Function


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

Dim cell
Dim ForeColor       As OLE_COLOR
Dim cText           As clsText

    If dicCell(page, cutpage).Count > 0 Then
        '*得到线宽和颜色
        obj.DrawWidth = IIf(sRate < 1, 1, CInt(sRate))
        ForeColor = vbBlack 'cText.foreColor
        
        '*绘制整个区域的左边框和顶部边框
        obj.Line (left * sRate, Top * sRate)-Step(GetWidth(cutpage) * sRate, 0), ForeColor
        obj.Line (left * sRate, Top * sRate)-Step(0, GetHeight(page) * sRate), ForeColor
    End If
    
    For Each cell In dicCell(page, cutpage).Items
    
        With cell
            Set cText = colText(cell.colFrom)
            
            cText.stringX = .stringX
            cText.left = left + cText.left
            cText.Top = Top + cell.Top
            cText.height = .height
            
            '*输出
            cText.PrintIt obj, sRate

            '*恢复设置
            cText.left = cText.left - left

        End With
        
    Next
    
End Function


'**************************************************************
'*名称：GetHeight
'*功能：得到正文的高度
'*传入参数：
'*      page            --页数
'*返回参数：
'*      此页的正文高度
'*作者：chlf78
'*日期：2002-04-05 15:35:54
'***************************************************************
Public Function GetHeight(page As Integer) As Single

    On Error GoTo err_proc
    
    GetHeight = dicPageHeight.item(page)
    
    Exit Function
    
'*错误处理
err_proc:
    GetHeight = 0