dym1report.ctl

此为vb6做的报表打印控件源码

End Enum

Dim mcolColEditMax As New Collection
Dim mcolColEditMin As New Collection
Dim mbolAltDown As Boolean
'Default Property Values:
Const m_def_HighLight = 0
Const m_def_bolAllowDragCol = False
Const m_def_bolColEditable = True
Const m_def_bolIsTotalShow = False
Const m_def_bolTitleIsVisible = True
Const m_def_Title = "报表标题"
Const m_def_ReportStyle = 1
Const m_def_SubTitles = "副标题|格式|用分号换行|用竖线换列"

'********************************************
'私有变量
'Property Variables:
Dim m_HighLight As ShowSelSettings
Dim m_bolAllowDragCol As Boolean
Dim m_bolColEditable As Boolean
Dim m_bolIsTotalShow As Boolean '是否显示总计
Dim m_bolTitleIsVisible As Boolean '是否显示标题
Dim m_Title As String             '报表标题
Dim m_RecordSet As RecordSet      '数据源
Dim m_ReportStyle As dym1ReportStyle
Dim m_SubTitles As String         '子标题
Dim mcolTotalType As New Collection  '对每列的一种汇总的方式
Dim mcolTotalTypes As New Collection  '用户可选择的汇总方式
Dim mcolVirtualCol As New Collection  '在列交换后保存列原始位置
Dim mcolColEditAble As New Collection  '保存某列是否可修改
Dim mintCol As Integer
Dim mlngChangeRow As Long

'Event Declarations:
Event KeyDown(KeyCode As Integer, Shift As Integer) 'MappingInfo=cfgdReport,cfgdReport,-1,KeyDown
Event ValidateEdit(Row As Long, Col As Long, Cancel As Boolean) 'MappingInfo=cfgdReport,cfgdReport,-1,ValidateEdit
Attribute ValidateEdit.VB_Description = "Fired before the control exits cell edit mode."
Event CellButtonClick(Row As Long, Col As Long) 'MappingInfo=cfgdReport,cfgdReport,-1,CellButtonClick
Attribute CellButtonClick.VB_Description = "Fired after the user clicks a cell button."
Event Click() 'MappingInfo=cfgdReport,cfgdReport,-1,Click
Event DblClick() 'MappingInfo=UserControl,UserControl,-1,DblClick
Attribute DblClick.VB_Description = "当用户在一个对象上按下并释放鼠标按钮后再次按下并释放鼠标按钮时发生。"
Event GetHeaderRow(Row As Long, HeaderRow As Long) 'MappingInfo=cfgdReport,cfgdReport,-1,GetHeaderRow
Attribute GetHeaderRow.VB_Description = "Fired while printing the control to set repeating header rows."
Event Hide() 'MappingInfo=UserControl,UserControl,-1,Hide
Attribute Hide.VB_Description = "当控件的 Visible 属性变为 False 时发生。"
'Event KeyDown(KeyCode As Integer, Shift As Integer)
Event KeyDownEdit(Row As Long, Col As Long, KeyCode As Integer, Shift As Integer) 'MappingInfo=cfgdReport,cfgdReport,-1,KeyDownEdit
Attribute KeyDownEdit.VB_Description = "Fired when the user presses a key in cell-editing mode."
Event KeyPress(KeyAscii As Integer) 'MappingInfo=cfgdReport,cfgdReport,-1,KeyPress
Event KeyPressEdit(Row As Long, Col As Long, KeyAscii As Integer) 'MappingInfo=cfgdReport,cfgdReport,-1,KeyPressEdit
Attribute KeyPressEdit.VB_Description = "Fired when the user presses a key in cell-editing mode."
Event Scroll() 'MappingInfo=cfgdReport,cfgdReport,-1,Scroll
Attribute Scroll.VB_Description = "Fired after the control scrolls."
Event MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=cfgdReport,cfgdReport,-1,MouseDown
Event MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=UserControl,UserControl,-1,MouseMove
Event MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single) 'MappingInfo=cfgdReport,cfgdReport,-1,MouseUp
Event ChangeEdit() 'MappingInfo=cfgdReport,cfgdReport,-1,ChangeEdit
Attribute ChangeEdit.VB_Description = "Fired after the text in the editor has changed."
Event AfterEditARow(ChangeRow As Long)
Public Event PreView(paraPreviewMode As Boolean)

Private Sub ccmdPage_Click(Index As Integer)
With cPrnReport
    Select Case Index
    Case 0:
        .PreviewPage = 1
    Case 1:
        .PreviewPage = .PreviewPage - 1
    Case 2:
        .PreviewPage = .PreviewPage + 1
    Case 3:
        .PreviewPage = .CurrentPage
    Case 4
        If .Zoom < 100 Then .Zoom = .Zoom + 10
    Case 5
        If .Zoom > 10 Then .Zoom = .Zoom - 10
    End Select
End With
End Sub

Private Sub cfgdReport_AfterEdit(ByVal Row As Long, ByVal Col As Long)
    With cfgdReport
        If ColDataType(Col) = flexDTDouble Then
            .TextMatrix(Row, Col) = Format(.TextMatrix(Row, Col), "###########.#######")
        Else
            .TextMatrix(Row, Col) = .Cell(flexcpTextDisplay, Row, Col)
        End If
        mlngChangeRow = Row
        mbolEventLock = False
    End With
End Sub

'当用户拖动标题栏时,自动汇总
Private Sub cfgdReport_AfterMoveColumn(ByVal Col As Long, Position As Long)
    
    Dim i As Integer
    Dim lintType As Integer '汇总方式
    
    On Error GoTo errhandle
    With cfgdReport
    '首先记录改动后的各列的位置
        i = mcolVirtualCol(Col + 1)
        mcolVirtualCol.Remove Col + 1
        If Position = .Cols - 1 Then
            mcolVirtualCol.Add i
        Else
            If Position <> 0 Then
                 mcolVirtualCol.Add i, , Position + 1
                 Else
                 mcolVirtualCol.Add i, , 1
             End If
        End If
    If RecordSet Is Nothing Then Exit Sub
        Call subShowResult
        End With
    Exit Sub
errhandle:
    Err.Raise 200101, "dym1Grid", "AterMoveColumn出错"
End Sub
'根据第一列的分组方式来对各列进行汇总
Public Sub subShowResult()
    Dim i As Integer
    Dim lintType  As Integer
    Dim lstrFormat As String
    On Error GoTo errhandle
    '根据各列自己的汇总方式来进行汇总
    With cfgdReport
        '.Redraw = False
        .Subtotal flexSTClear '清空原来的汇总行
        
        .Select 1, 0, 1, 0    '第一行排序
        .Sort = flexSortGenericAscending
        
        For i = 1 To .Cols - 1
            lintType = intTotalType(mcolVirtualCol(i + 1) + 1)
            lstrFormat = funcstrColFormat(lintType, i)
            If m_bolIsTotalShow Then
                .Subtotal lintType, -1, i, lstrFormat, vbBlue, vbWhite, True, "共计"
            End If
            .Subtotal lintType, 0, i, lstrFormat, &H404000, vbWhite, True
            
        Next
       
    ' autosize
        .AutoSize 0, .Cols - 1, , 300
        .OutlineBar = flexOutlineBarComplete
        .Outline 2
        .OutlineCol = 0
        
    ' turn repainting back on
        .Redraw = True
        
    End With
    Exit Sub
errhandle:
    Err.Raise 200102, "dym1Grid", "subshowresult出错"
End Sub
'判断某列是否可以被修改
Private Sub cfgdReport_BeforeEdit(ByVal Row As Long, ByVal Col As Long, Cancel As Boolean)
    On Error GoTo errhandle
    Dim lintC As Integer
    lintC = mcolVirtualCol(Col + 1)
    If bolColEditable(lintC) = True Then
        Cancel = False
        
    Else
        Cancel = True
    End If
    Exit Sub
errhandle:
    Err.Raise 200103, "系统", "过程BeforeEdit"
End Sub

Private Sub cfgdReport_BeforeMoveColumn(ByVal Col As Long, Position As Long)
    If bolAllowDragCol = False Then
        Position = Col
    End If
End Sub


'*******************************************
  ' 打印时显示各列题头
  Private Sub cfgdReport_GetHeaderRow(ByVal Row As Long, HeaderRow As Long)
    RaiseEvent GetHeaderRow(Row, HeaderRow)
    Dim r As Long
    
    ' ignore if the top row is a header already
    If cfgdReport.Rows > 1 Then
        If cfgdReport.RowData(Row) = -1 Then Exit Sub
    End If
    ' we need a header, so find one
    For r = cfgdReport.FixedRows To cfgdReport.Rows - 1
      If cfgdReport.RowData(r) = -1 Then
        HeaderRow = r
        Exit Sub
      End If
    Next
  End Sub
    
  '打印子标题时防止断页
  Private Sub cfgdreport_BeforePageBreak(ByVal Row As Long, BreakOK As Boolean)
    With cfgdReport
        
      ' if this row is a subtotal heading, we can't break here
      If .IsSubtotal(Row) Then
        BreakOK = False
      End If
    End With
  End Sub

'根据各列汇总方式设置各列的格式
'入口:汇总方式
    ':列号
'返回:对应格式

Private Function funcstrColFormat(ByVal paraTotalType As SubtotalSettings, paraCol As Integer) As String
    Dim lstrT As String
    Dim lbolF As Boolean
    Dim i
    With cfgdReport
    '判断此列是否有小数点
    For i = 1 To .Rows - 1
        If InStr(1, .TextMatrix(i, paraCol), ".") <> 0 Then lbolF = True: Exit For Else lbolF = False
    Next
    Select Case paraTotalType
        Case flexSTSum
            If lbolF = True Then lstrT = "ss(#,###.00)" Else lstrT = "ss(#,###)"
        Case flexSTAverage
            lstrT = "(#,###.00)"
        Case flexSTCount
            lstrT = "(#,###)"
        
    End Select
    End With
        funcstrColFormat = lstrT
End Function
'双击表格则合并所在列的单元格
Private Sub cfgdReport_DblClick()
    With cfgdReport
    '.MergeCells = flexMergeFree
    '.Select 1, .MouseCol, .Rows - 1, .MouseCol
    '.CellBorder vbBlack, 0, 0, -1, 0, 2, 2
    '.MergeCol(.MouseCol) = Not .MergeCol(.MouseCol)
    RaiseEvent DblClick
    End With
End Sub

Private Sub cfgdReport_LostFocus()
With cfgdReport
        If mlngChangeRow <> 0 And mbolEventLock = False Then
            mbolEventLock = True
            RaiseEvent AfterEditARow(mlngChangeRow)
            mlngChangeRow = 0
        End If
End With
End Sub

'右键显示菜单
Private Sub cfgdReport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    RaiseEvent MouseDown(Button, Shift, X, Y)
    Dim lintCol As Integer
    Dim i As Integer
    If m_RecordSet Is Nothing Then Exit Sub
    If Button = vbRightButton Then
        With cfgdReport
            If .MouseRow <> 0 Then '如果不是首列则显示操作菜单否则显示隐藏菜单
            '首先保存鼠标所在列
              lintCol = mcolVirtualCol(.MouseCol + 1)
              mintCol = .MouseCol
             '根据mcoltotaltypes的值来设置弹出菜单的有效的项
             '通过与操作进行判断哪些菜单项应该显示
                For i = 0 To 4
                If ((2 ^ i) And mcolTotalTypes(lintCol + 1)) <> 0 Then
                    mnufield1(i).Enabled = True
                Else
                    mnufield1(i).Enabled = False
                End If
                Next i
                PopupMenu mnuField(0)
            Else
                For i = 0 To .Cols - 1
                    If mnuCol.Count <= i + 1 Then
                        Load mnuCol(i + 1)
                    End If
                    mnuCol(i + 1).Caption = .TextArray(i)
                    mnuCol(i + 1).Checked = Not .ColHidden(i)
                Next
                PopupMenu mnuShow
            End If
        End With
    End If
End Sub
'发生AfterEditRow 的事件
Private Sub cfgdReport_SelChange()
    With cfgdReport
        If .Row <> mlngChangeRow And mlngChangeRow <> 0 And mbolEventLock = False Then
            mbolEventLock = True
            RaiseEvent AfterEditARow(mlngChangeRow) 'mlngchangerow 表示被修改的行的行号
            mlngChangeRow = 0
        End If
    End With
End Sub

Private Sub cPrnReport_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 18 Then
        mbolAltDown = True
    End If
End Sub

Private Sub cPrnReport_KeyUp(KeyCode As Integer, Shift As Integer)
    If KeyCode = 18 Then
        mbolAltDown = False
    End If
End Sub

Private Sub cPrnReport_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    If Button = vbRightButton Then
        subPrintPreview False
    Else
        With cPrnReport
            If mbolAltDown = False Then
            .MouseIcon = LoadResPicture(105, vbResCursor): .MousePointer = 99
            If .Zoom < 100 Then .Zoom = .Zoom + 10
            Else
             .MouseIcon = LoadResPicture(106, vbResCursor): .MousePointer = 99
            If .Zoom > 10 Then .Zoom = .Zoom - 10
            End If
        End With
    End If
End Sub

'根据菜单项决定该隐藏哪列
Private Sub mnuCol_Click(Index As Integer)
    With cfgdReport
        If Index <> 0 Then .ColHidden(Index - 1) = mnuCol(Index).Checked
    End With
End Sub

Private Sub mnufield1_Click(Index As Integer)
'根据汇总菜单选择不同的汇总方式
'首先取最初的列的原始位置（在没有拖动之前）
Dim lintI As Integer
    lintI = mcolVirtualCol(mintCol + 1) + 1
    
    Select Case Index
        Case 0:
            intTotalType(lintI) = flexSTSum
        Case 1:
            intTotalType(lintI) = flexSTAverage
        Case 2:
            intTotalType(lintI) = flexSTCount
        Case 3:
            intTotalType(lintI) = flexSTMax
        Case 4:
            intTotalType(lintI) = flexSTMin
    End Select
    Call subShowResult
End Sub

Private Sub UserControl_Resize()
    On Error Resume Next
    Title = m_Title
    bolTitleIsVisible = m_bolTitleIsVisible
    SubTitles = m_SubTitles
    ReportStyle = m_ReportStyle
    cfgdTitle.Move 0, 0, UserControl.Width
    cfgdReport.Move 0, cfgdTitle.Height, UserControl.Width, UserControl.Height - cfgdReport.Top
    
End Sub
'打印预览
Public Sub subPrintPreview(paraPreviewFlag As Boolean)
 Dim lstrT As String
 Dim i As Integer
 Dim j As Integer
 Dim lstrFormat As String
    RaiseEvent PreView(paraPreviewFlag)
    If paraPreviewFlag Then
        'subClearTitleBoder