modattachlistview.bas

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

Attribute VB_Name = "ModAttachListView"

Option Explicit
'**************************************************************
'*模块名称：ModAttachListView
'*模块功能：将FlexGrid中的数据添加到报表类
'*说明：
'*
'*备注：
'*
'*作者：chlf78
'*日期：2002-04-28 12:21:58
'***************************************************************

Private Const ModalName = "ModAttachListView"


'**************************************************************
'*名称：ModAttachListView
'*功能：将ListView中的数据添加到报表类
'*传入参数：
'*      rpt             --报表类
'*      listview        --ListView控件
'*返回参数：
'*      是否成功
'*作者：chlf78
'*日期：2002-04-09 18:58:40
'**************************************************************
Public Function funAttachListView(rpt As Report, listview As Object) As Boolean

Dim i               As Integer
Dim j               As Integer
Dim cell            As clsCell          '*单元格
Dim cellnew         As clsCellNew
Dim col             As Integer
Dim cText           As clsText
Dim alignColHeader  As typeAlign        '*列头对齐方式
Dim alignCol        As typeAlign        '*列对齐方式

    
    On Error GoTo err_proc
    
    With listview
        col = 0
        For i = 1 To .ColumnHeaders.Count
            If .ColumnHeaders(i).width > LEASTWIDTH Then
                col = col + 1
            End If
        Next i
        
        '*设置对象的行列数
        rpt.ColHeader.SetColRows col, 1
        rpt.Content.SetColRows col, listview.ListItems.Count
        
        col = 0
        For i = 1 To .ColumnHeaders.Count
        
            If .ColumnHeaders(i).width > LEASTWIDTH Then
                col = col + 1

                
                '*取列头对齐和列对齐方式
                Select Case .ColumnHeaders(i).Alignment
                    Case 0
                        alignCol = tyLeft
                    Case 1
                        alignCol = tyRight
                    Case 2
                        alignCol = tymiddle
                End Select

                alignColHeader = tymiddle
                
                '*列头
                For j = 1 To 1

                    Set cell = New clsCell
                    With cell
                        .colFrom = col
                        .colTo = col
                        .rowFrom = j
                        .rowTo = j
                        .text.drawBorder = True
                        .text.stringX = listview.ColumnHeaders(i).text
                        .text.Align = alignColHeader
                        .text.width = listview.ColumnHeaders(i).width
                        .text.height = CalHeight(listview.Font.Size) + 2 * MYSPACE
                        .text.rowheight = .text.height
                        .text.ForeColor = vbBlack
                    End With
                    rpt.ColHeader.SetCell cell
                    Set cell = Nothing
                Next j
                
                '*设置正文的列属性
                Set cText = New clsText
                With cText
                    .rowheight = CalHeight(listview.Font.Size) + 2 * MYSPACE
                    .width = listview.ColumnHeaders(i).width
                    .Align = alignCol
                    .ForeColor = listview.ListItems(1).ForeColor
                    .drawBorder = True
                    .Align = alignCol
                    rpt.Content.SetColText col, cText
                End With
                Set cText = Nothing
                
                '*正文
                For j = 1 To .ListItems.Count
                    Set cellnew = New clsCellNew
                    With cellnew
                        .colFrom = col
                        .colTo = col
                        .rowFrom = j
                        .rowTo = j
                        If i = 1 Then
                            .stringX = listview.ListItems(j).text
                        Else
                            .stringX = listview.ListItems(j).SubItems(i - 1)
                        End If
                        .height = CalHeight(listview.Font.Size) + 2 * MYSPACE
                    End With
                    rpt.Content.SetCell cellnew
                    Set cellnew = Nothing
                Next j
            End If
        Next i
        
    End With
    funAttachListView = True
    Exit Function
    
err_proc:
    funAttachListView = False
End Function