modattachmrc.bas

ktv场所的包房开房、迎宾、预定管理系统。

Attribute VB_Name = "ModAttachmrc"
Option Explicit
'**************************************************************
'*模块名称：ModAttachFlexGrid
'*模块功能：将mrc中的数据添加到报表类
'*说明：
'*
'*备注：
'*
'*作者：progame
'*日期：2002-04-09 18:54:58
'***************************************************************

Private Const ModalName = "ModAttachmrc"


'**************************************************************
'*名称：Attachmrc
'*功能：将mrc(MSHmrc)中的数据添加到报表类
'*传入参数：
'*      rpt                 --报表类
'*      mrc            --网格控件
'*返回参数：
'*      是否成功
'*作者：progame
'*日期：2002-04-09 18:58:40
'**************************************************************
Public Function funAttachmrc(rpt As report, mrc As ADODB.Recordset, strheadname() As String, numheadwith() As Integer) 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 mrc
        '*设置对象的行列数
        '.Fields
        rpt.ColHeader.SetColRows mrc.Fields.Count, 1
        rpt.Content.SetColRows mrc.Fields.Count, .RecordCount
        col = 0
        For i = 0 To .Fields.Count - 1
            .MoveFirst
'            If .colWidth(i) > LEASTWIDTH Then
                col = col + 1
                '*取列头对齐和列对齐方式
                alignColHeader = tymiddle ' Int(.ColAlignmentHeader(0, i - 1) / 3)
                'alignCol = Int(.ColAlignment(i) / 3)
                '.col = i
                '*列头
                For j = 1 To 1
                    '.row = j - 1
                    Set cell = New clsCell
                    With cell
                        .colFrom = col
                        .colTo = col
                        .rowFrom = j
                        .rowTo = j
                        .text.drawBorder = True
                        '.text.stringX = mrc.Fields.item(i).Name
                        .text.stringX = strheadname(i + 1)
                        .text.Align = alignColHeader
                        .text.width = numheadwith(i + 1)
                        '.text.width = mrc.Fields.item(i).DefinedSize + 1000
                        .text.height = 350
                        .text.rowheight = .text.height
                        .text.fontsize = 10
                       ' .text.ForeColor = mrc.CellForeColor
                    End With
                    rpt.ColHeader.SetCell cell
                    Set cell = Nothing
                Next j
                
                '*设置正文的列属性
                '.row = mrc.FixedRows
                Set cText = New clsText
                With cText
                   .rowheight = 350
                    .width = numheadwith(i + 1)
                    .drawBorder = True
                    .Align = alignCol
                    .height = 350
                   ' .ForeColor = mrc.CellForeColor
                    .fontsize = 10
                    rpt.Content.SetColText col, cText
                End With
                Set cText = Nothing
                
                '*正文
                For j = 1 To .RecordCount
                Set cellnew = New clsCellNew
                    With cellnew
                        .colFrom = col
                        .colTo = col
                        .rowFrom = j
                        .rowTo = j
                        .stringX = IIf(mrc.Fields(i).Type = 6, Format(mrc.Fields(i), "0.0"), "" & mrc.Fields(i))
                        '.height = mrc.rowheight(j + mrc.FixedRows - 1)
                        
                    End With
                    rpt.Content.SetCell cellnew
                    Set cellnew = Nothing
                    .MoveNext
                Next j
                
                '*设置合并列
'                If .mergeCol(i - 1) Then
'                    rpt.Content.SetMergeCol 1, True
'                    rpt.Content.SetMergeCol 2, True
'                End If
            'End If
        Next i
        
    End With
    funAttachmrc = True
    Exit Function
    
err_proc:
    funAttachmrc = False
    MsgBox Err.Number & Err.Description
End Function