dym1report1.ctl

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

Public Property Let ReportStyle(ByVal New_ReportStyle As dym1ReportStyle)
    Dim i As Long
    
    
    m_ReportStyle = New_ReportStyle
    cfgdTitle.Redraw = False
    cfgdReport.Redraw = False
    cfgdTitle.GridLines = flexGridInset
    Select Case m_ReportStyle
        Case dym1Report3D:
            With cfgdTitle
                .Appearance = flex3D
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = vb3DFace
                .CellForeColor = vbHighlight
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vb3DFace
                .CellForeColor = vbBlack
                
                .CellBorder vbBlack, 1, 1, 1, 1, 1, 1
            End With
            With cfgdReport
                .Appearance = flex3D
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = vb3DFace
                .CellForeColor = vbHighlight
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vb3DFace
                .CellForeColor = vbBlack
                .CellBorder vbBlack, 1, 1, 1, 1, 1, 1
            End With
        Case dym1ReportClassic:
            With cfgdTitle
                .Appearance = flexFlat
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = vbWhite
                .CellForeColor = vbBlack
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vbWhite
                .CellForeColor = vbBlack
            End With
            With cfgdReport
                .Appearance = flexFlat
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = vbWhite
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vbWhite
                              
            End With
        Case dym1ReportGreen
            With cfgdTitle
                .Appearance = flexFlat
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = RGB(30, 120, 30)
                .CellForeColor = vbWhite
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vbWhite
                .CellBorder vbBlack, 1, 1, 1, 1, 1, 1
            End With
            With cfgdReport
                .Appearance = flexFlat
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = RGB(30, 120, 30)
                .CellForeColor = vbWhite
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = vbWhite
                .CellBorder vbBlack, 1, 1, 1, 1, 1, 1
                .CellForeColor = vbBlack
            End With
        Case dym1ReportActive
            
            With cfgdTitle
                .Appearance = flexFlat
                .Select 0, 0, .Rows - 1, .Cols - 1
                .CellBackColor = &HC0FFFF
                .CellForeColor = vbBlue
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBackColor = &HFFFFC0
                .CellBorder vbBlue, 1, 1, 1, 1, 1, 1
            End With

            With cfgdReport
                .Appearance = flexFlat
                .Select 0, 0, 0, .Cols - 1
                .CellBackColor = &HC0FFFF
                .CellForeColor = vbBlack
                For i = 1 To .Rows - 1 Step 2
                    .Select i, 0, i, .Cols - 1
                    .CellBackColor = &HFFFFC0
                Next
'
                For i = 2 To .Rows - 1 Step 2
                    .Select i, 0, i, .Cols - 1
                    .CellBackColor = vbWhite
                Next
                .Select 1, 0, .Rows - 1, .Cols - 1
                .CellBorder vbBlack, 1, 1, 1, 1, 1, 1
            End With
    End Select
    With cfgdTitle
        .Row = 0
        .Col = 1
        .Redraw = True
    End With
   With cfgdReport
        .Row = 0
        .Redraw = True
    End With
    PropertyChanged "ReportStyle"
End Property



Public Property Get SubTitles() As String
    SubTitles = m_SubTitles
End Property

Public Property Let SubTitles(ByVal New_SubTitles As String)
    Dim lcolSubtitle As New Collection
    Dim lr As Integer, lc As Integer
    Dim i As Long
    Dim llngHeight As Long
 On Error GoTo errh
    m_SubTitles = New_SubTitles
    If New_SubTitles <> "" Then
       '得到副标题的内容
        Set lcolSubtitle = funcSplitWord(";|", m_SubTitles)
        
        '得到副标题的的行数列数
        subSubTitleInfo lr, lc
        
        If lc = 1 Then lc = 2
        With cfgdTitle
        
        .Rows = lr + 1
        .Cols = lc
        '填充副标题的内容
        For i = 1 To lcolSubtitle.Count
            .TextArray(i + .Cols - 1) = lcolSubtitle(i)
        Next
        
        .RowHeight(0) = 600
        .RowHeight(1) = 400
        .Select 1, 0, .Rows - 1, .Cols - 1
        .ColWidth(-1) = .ClientWidth \ .Cols
        .CellFontSize = 9
        .CellFontName = "楷体"
        For i = 0 To .Cols - 1 Step 2
            .Select 1, i, .Rows - 1, i
            .CellFontBold = True
        Next
        llngHeight = .RowHeight(0) + .RowHeight(1) * lr
        .Move 0, 0, .Width, llngHeight
        End With
        
    Else
        With cfgdTitle
        .Cols = 2
        '如果无子标题，就将列设置成为2列
        .ColWidth(0) = Width / 2
        .ColWidth(1) = Width / 2
        .RowHidden(1) = True
        .Height = .RowHeight(0)
        Height = .Height + cfgdReport.Height
        End With
        
End If
    cfgdReport.Move 0, cfgdTitle.Height, UserControl.Width, UserControl.Height - cfgdReport.Top - 100
    Title = m_Title
    'Call UserControl_Resize
    
    PropertyChanged "SubTitles"
    Exit Property
errh:
    Err.Raise 111002, , "设置子标题出错"
End Property

'为用户控件初始化属性
Private Sub UserControl_InitProperties()
    Dim i As Integer
    m_Title = m_def_Title
    m_ReportStyle = m_def_ReportStyle
    m_SubTitles = m_def_SubTitles
    m_bolTitleIsVisible = m_def_bolTitleIsVisible
    m_bolIsTotalShow = m_def_bolIsTotalShow
    m_bolColEditable = m_def_bolColEditable
    For i = 0 To cfgdReport.Cols - 1
        mcolTotalTypes.Add 0
        mcolTotalType.Add 0
        mcolVirtualCol.Add i
        mcolColEditAble.Add False
    Next
    m_bolAllowDragCol = m_def_bolAllowDragCol
    m_HighLight = m_def_HighLight
End Sub

'从存贮器中加载属性值
Private Sub UserControl_ReadProperties(PropBag As PropertyBag)
Dim Index As Integer
Dim i As Integer
    m_Title = PropBag.ReadProperty("Title", m_def_Title)
    m_ReportStyle = PropBag.ReadProperty("ReportStyle", m_def_ReportStyle)
    m_SubTitles = PropBag.ReadProperty("SubTitles", m_def_SubTitles)
    cfgdReport.OutlineBar = PropBag.ReadProperty("OutlineBar", 0)
    cfgdReport.OutlineCol = PropBag.ReadProperty("OutlineCol", 0)
    m_bolTitleIsVisible = PropBag.ReadProperty("bolTitleIsVisible", m_def_bolTitleIsVisible)
    m_bolIsTotalShow = PropBag.ReadProperty("bolIsTotalShow", m_def_bolIsTotalShow)
    For i = 0 To cfgdReport.Cols - 1
        mcolTotalTypes.Add 0
        mcolTotalType.Add 0
        mcolVirtualCol.Add i
        mcolColEditAble.Add False
    Next
 '   cPrnReport.PageCount = PropBag.ReadProperty("PageCount", 0)
'TO DO: 将要映射到的成员包含数据数组。  cfgdReport.ColDataType(Col) = PropBag.ReadProperty("ColDataType" & Index, 0)
    cfgdReport.ComboList = PropBag.ReadProperty("ComboList", "")
    cfgdReport.ComboIndex = PropBag.ReadProperty("ComboIndex", 0)
'TO DO: 将要映射到的成员包含数据数组。  cfgdReport.ColDataType(Col) = PropBag.ReadProperty("ColDataType" & Index, 0)
'TO DO: 将要映射到的成员包含数据数组。  cfgdReport.ColComboList(Col) = PropBag.ReadProperty("ColComboList" & Index, "")
'TO DO: 将要映射到的成员包含数据数组。  cfgdReport.TextMatrix(Row,Col) = PropBag.ReadProperty("TextMatrix" & Index, "")
    m_bolAllowDragCol = PropBag.ReadProperty("bolAllowDragCol", m_def_bolAllowDragCol)
    cfgdReport.Cols = PropBag.ReadProperty("Cols", 10)
    cPrnReport.PreviewPage = PropBag.ReadProperty("PreviewPage", 0)
    cfgdReport.Row = PropBag.ReadProperty("Row", 0)
    cfgdReport.Rows = PropBag.ReadProperty("Rows", 50)
    cfgdReport.Col = PropBag.ReadProperty("Col", 0)
'TO DO: 将要映射到的成员包含数据数组。  cfgdReport.ColEditMask(Col) = PropBag.ReadProperty("ColEditMask" & Index, "")
    m_HighLight = PropBag.ReadProperty("HighLight", m_def_HighLight)
End Sub

'将属性值写到存储器
Private Sub UserControl_WriteProperties(PropBag As PropertyBag)
Dim Index As Integer

    Call PropBag.WriteProperty("Title", m_Title, m_def_Title)
    Call PropBag.WriteProperty("ReportStyle", m_ReportStyle, m_def_ReportStyle)
    Call PropBag.WriteProperty("SubTitles", m_SubTitles, m_def_SubTitles)
    Call PropBag.WriteProperty("OutlineBar", cfgdReport.OutlineBar, 0)
    Call PropBag.WriteProperty("OutlineCol", cfgdReport.OutlineCol, 0)
    Call PropBag.WriteProperty("bolTitleIsVisible", m_bolTitleIsVisible, m_def_bolTitleIsVisible)
    Call PropBag.WriteProperty("bolIsTotalShow", m_bolIsTotalShow, m_def_bolIsTotalShow)
  '  Call PropBag.WriteProperty("PageCount", cPrnReport.PageCount, 0)
'TO DO: 将要映射到的成员包含数据数组。  Call PropBag.WriteProperty("ColDataType" & Index,cfgdReport.ColDataType(Col), 0)
    Call PropBag.WriteProperty("ComboList", cfgdReport.ComboList, "")
'TO DO: 将要映射到的成员包含数据数组。  Call PropBag.WriteProperty("ColDataType" & Index,cfgdReport.ColDataType(Col), 0)
'TO DO: 将要映射到的成员包含数据数组。  Call PropBag.WriteProperty("ColComboList" & Index,cfgdReport.ColComboList(Col), "")
'TO DO: 将要映射到的成员包含数据数组。  Call PropBag.WriteProperty("TextMatrix" & Index,cfgdReport.TextMatrix(Row,Col), "")
    Call PropBag.WriteProperty("bolAllowDragCol", m_bolAllowDragCol, m_def_bolAllowDragCol)
    Call PropBag.WriteProperty("Cols", cfgdReport.Cols, 10)
    Call PropBag.WriteProperty("PreviewPage", cPrnReport.PreviewPage, 0)
    Call PropBag.WriteProperty("Row", cfgdReport.Row, 0)
    Call PropBag.WriteProperty("Rows", cfgdReport.Rows, 50)
    Call PropBag.WriteProperty("Col", cfgdReport.Col, 0)
'TO DO: 将要映射到的成员包含数据数组。  Call PropBag.WriteProperty("ColEditMask" & Index,cfgdReport.ColEditMask(Col), "")
    Call PropBag.WriteProperty("HighLight", m_HighLight, m_def_HighLight)
End Sub

'计算子标题的行数和列数
Private Sub subSubTitleInfo(ByRef paraRows As Integer, ByRef paraCols As Integer)
    Dim i As Integer, j As Integer
    Dim s As String
    Dim t As Integer
    
    paraRows = 0
    paraCols = 0
    
    If m_SubTitles <> "" Then
        paraRows = 1: paraCols = 1
    Else
        Exit Sub
    End If

    For i = 1 To Len(m_SubTitles)
        s = Mid(m_SubTitles, i, 1)
        If s = ";" Then
            paraRows = paraRows + 1
            If t < paraCols Then
                t = paraCols
            End If
            paraCols = 1
        End If
        
        If s = "|" Then
            paraCols = paraCols + 1
        End If
    Next
        If t <> 0 Then paraCols = t
   End Sub
'将特定字符转换为一个集合
'入口:paraSplitSign 字符的分割号
'     paraSource    要转换的字符
'返回:将字符根据分割符号逐项加入集合
Public Function funcSplitWord(paraSplitSign As String, paraSource As String) As Collection
    Dim lcolS As New Collection
    Dim lstrChar As String
    Dim lintStart As Integer
    Dim lintLen As Integer
    Dim lstrCharSRC As String
    Dim i As Integer
    Dim j As Integer
    
    lintStart = 1
    
    For i = 1 To Len(paraSource)
        lstrCharSRC = Mid(paraSource, i, 1)
        'find  every char in the splitsign
        For j = 1 To Len(paraSplitSign)
            lstrChar = Mid(paraSplitSign, j, 1)
        'if the char is in the source
            If lstrChar = lstrCharSRC Then
                lcolS.Add Mid(paraSource, lintStart, i - lintStart)
                lintStart = i + 1
        'if find the split char then exit loop and do the next compare
                Exit For
            End If
            
        Next
    Next
    
    lcolS.Add Mid(paraSource, lintStart, i - lintStart)
    
    Set funcSplitWord = lcolS
End Function
'隐藏某列
Public Function ColHidden(Col As Long, bolHidden As Boolean)
    With cfgdReport
        .ColHidden(Col) = bolHidden
    End With
End Function

'对某列汇总的方式
Public Property Get intTotalType(Index As Integer) As dym1TotalType
On Error GoTo errhandle
    intTotalType = mcolTotalType(Index)
    Exit Property
errhandle:
    Err.Raise 111001, , "索引值错误"
End Property

Public Property Let intTotalType(Index As Integer, paraType As dym1TotalType)
On Error GoTo errhandle
    Select Case Index
    Case mcolTotalType.Count
        mcolTotalType.Remove (Index)
        mcolTotalType.Add paraType
    Case 1
        mcolTotalType.Add paraType, , 1
        mcolTotalType.Remove (2)
    Case Else
        mcolTotalType.Remove (Index)
        mcolTotalType.Add paraType, , Index
    End Select
    Exit Property
errhandle:
    Err.Raise 111001, , "索引值错误"
    
End Property
Public Property Get intTotalTypes(Index As Integer) As dym1TotalType
On Error GoTo errhandle
    intTotalTypes = mcolTotalTypes(Index)
    Exit Property
errhandle:
    Err.Raise 111001, , "索引值错误"
End Property

Public Property Let intTotalTypes(Index As Integer, paraType As dym1TotalType)
On Error GoTo errhandle
    Select Case Index
    Case mcolTotalTypes.Count
        mcolTotalTypes.Remove (Index)
        mcolTotalTypes.Add paraType
    Case 1
        mcolTotalTypes.Remove (Index)
        mcolTotalTypes.Add paraType, , 1
    Case Else
        mcolTotalTypes.Remove (Index)
        mcolTotalTypes.Add paraType, , Index
    End Select
    Exit Property
errhandle:
    Err.Raise 111001, , "索引值错误"
    
End Property

'WARNING! DO NOT REMOVE OR MODIFY THE FOLLOWING COMMENTED LINES!cfgdReport,cfgdReport,-1,OutlineBar
Public Property Get OutlineBar() As OutlineBarSettings
Attribute OutlineBar.VB_Description = "Returns or sets the type of outline bar that should be displayed."