frmcrossbook.frm

金算盘软件代码

        lngFixedWidth = lngFixedWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
        If lngFixedWidth > mlngPageWidth Then
            Utility.ShowMsg Me.hwnd, "固定列太宽,请减小列宽!", vbOKOnly, App.title
            DispartPage = False
            Exit Function
        End If
    Next intCol
    '算列宽
    lngWidth = lngFixedWidth
    For intCol = msgAccount.FixedCols To msgAccount.Cols - 1
        lngWidth = lngWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
        If lngWidth > mlngPageWidth Then
            lngColExpands = lngColExpands + 1
            ReDim Preserve intColStart(lngColExpands)
            ReDim Preserve intColEnd(lngColExpands)
            lngWidth = lngFixedWidth + msgAccount.ColWidth(intCol) / Screen.TwipsPerPixelX
            intColEnd(lngColExpands - 1) = intCol - 1 - msgAccount.FixedCols
            intColStart(lngColExpands) = intCol - msgAccount.FixedCols
        End If
    Next intCol
    intColEnd(lngColExpands) = intCol - 1 - msgAccount.FixedCols
    mlngColExpands = lngColExpands + 1
    
    '''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '页纵向扩展
    mintPageRows = GetGridheight                              '得到最大页行数
    intRecCount = msgAccount.Rows - msgAccount.FixedRows
    If mintPageRows <= msgTitle.FixedRows Then
         Utility.ShowMsg Me.hwnd, "数据行数太小,请增加行数!", vbOKOnly, App.title
         DispartPage = False
         cmdFormatSet_Click
         Exit Function
    End If
    mlngRowExpands = intRecCount \ (mintPageRows - msgTitle.FixedRows) + 1
    
    mlngPages = mlngRowExpands * mlngColExpands
    ReDim mlngColStart(mlngPages - 1)
    ReDim mlngColEnd(mlngPages - 1)
    ReDim mlngRowStart(mlngPages - 1)
    ReDim mlngRowEnd(mlngPages - 1)
    For intRow = 0 To mlngRowExpands - 2
        For intCol = 0 To mlngColExpands - 1
            mlngColStart(intRow * mlngColExpands + intCol) = intColStart(intCol)
            mlngColEnd(intRow * mlngColExpands + intCol) = intColEnd(intCol)
            mlngRowStart(intRow * mlngColExpands + intCol) = intRow * (mintPageRows - msgTitle.FixedRows) + 1
            mlngRowEnd(intRow * mlngColExpands + intCol) = (intRow + 1) * (mintPageRows - msgTitle.FixedRows)
        Next intCol
    Next intRow
    '有最后一行记录的页
    For intCol = 0 To mlngColExpands - 1
            mlngColStart(intRow * mlngColExpands + intCol) = intColStart(intCol)
            mlngColEnd(intRow * mlngColExpands + intCol) = intColEnd(intCol)
            mlngRowStart(intRow * mlngColExpands + intCol) = intRow * (mintPageRows - msgTitle.FixedRows) + 1
            mlngRowEnd(intRow * mlngColExpands + intCol) = intRecCount
    Next intCol
    DispartPage = True
     '''''''''''
    'Added by Hebing!!!!!
    '
    ''''''''''''''''
'    mlngCurPage = 1
    CheckPages mlngPages
    SetPageContents VSpage.Value, mlngPages
    SetCurContents mlngCurPage
    
    
End Function
'填充数据
Private Sub SetData()
  Dim intRow As Integer, intCol As Integer
  Dim intCount As Integer
  Dim blnIsData As Boolean
    ABook.NewPage                                                 '清除记录
    If mlngCurPage > mlngPages Then mlngCurPage = mlngPages
    
    '''''''''Added by Heing         !!!!
     SetCurContents mlngCurPage
     
    setMaxCol mlngColEnd(mlngCurPage - 1) - mlngColStart(mlngCurPage - 1) + 1 + msgAccount.FixedCols
    SetDefColWidth 1110 / Screen.TwipsPerPixelX
    If mclsCross.GridTop = 0 Then
        SetGridTop 90
    Else
        SetGridTop mclsCross.GridTop / Screen.TwipsPerPixelY
    End If
    '设置表头区
    Caption = mclsCross.ReportName            '窗体标题
    SetGridTitle mclsCross.ReportName        '报表标题
    With msgTitle
        '设置栏目标题 (包括列宽)
        SetFixRow .FixedRows
        For intRow = 0 To .FixedRows - 1
            SetRowInfo intRow, GetDefRowheight * 1.1
            '固定列
            intCol = 0
            For intCount = 0 To msgAccount.FixedCols - 1
                Select Case UCase(mclsCross.ColumnFieldType(intCount))
                Case "BYTE", "INTEGER", "SINGLE", "DOUBLE", "DECIMAL", "LONG", "CURRENCY "
                    blnIsData = True
                Case Else
                    blnIsData = False
                End Select
                SetColumnInfo intCol, .ColWidth(intCount) / Screen.TwipsPerPixelX, blnIsData
                SetCell intCol, intRow, .TextMatrix(intRow, intCount), 4, vbRed, True
                ABook.MergeCell(intCol, intRow) = 1
                intCol = intCol + 1
            Next intCount
            '数据列
            For intCount = mlngColStart(mlngCurPage - 1) + msgAccount.FixedCols _
                            To mlngColEnd(mlngCurPage - 1) + msgAccount.FixedCols
                SetColumnInfo intCol, .ColWidth(intCount) / Screen.TwipsPerPixelX, True
                SetCell intCol, intRow, .TextMatrix(intRow, intCount), 4, vbRed, True
                ABook.MergeCell(intCol, intRow) = 1
                intCol = intCol + 1
            Next intCount
        Next intRow
    End With
        '设置数据区
    With msgAccount
        For intRow = msgTitle.FixedRows To mlngRowEnd(mlngCurPage - 1) - mlngRowStart(mlngCurPage - 1) + msgTitle.FixedRows
            '固定列
            intCol = 0
            For intCount = 0 To msgAccount.FixedCols - 1
                SetCell intCol, intRow, .TextMatrix(intRow + mlngRowStart(mlngCurPage - 1) - msgTitle.FixedRows, intCount), 1, vbRed, True
                ABook.MergeCell(intCol, intRow) = 1
                intCol = intCol + 1
            Next intCount
            '数据列
            For intCount = mlngColStart(mlngCurPage - 1) + msgAccount.FixedCols _
                            To mlngColEnd(mlngCurPage - 1) + msgAccount.FixedCols
                SetCell intCol, intRow, Format(.TextMatrix(intRow + mlngRowStart(mlngCurPage - 1) - msgTitle.FixedRows, intCount), "Fixed"), 8
                intCol = intCol + 1
            Next intCount
        Next intRow
    End With
    AddHeadTail                                           '加表头表尾
    ABook.DoMerge
    Dim strTemp As String
    For intCount = 0 To 5
        strTemp = strReplace(mstrHF(intCount), "&[页码]", str(mlngCurPage))
        strTemp = strReplace(strTemp, "&[总页数]", str(mlngPages))
        ABook.PageHF(intCount) = strTemp
    Next
    ABook.Refresh
End Sub

'设置GRID标题
Private Sub SetGridTitle(str As String)
    With mclsCross
        If .TitleHeight = 0 Then
            .TitleAlign = 4
            .TitleHeight = 22 * Screen.TwipsPerPixelX
        End If
        If .TitleWidth = 0 Then .TitleWidth = strLen(str) * 11 * Screen.TwipsPerPixelX + 180
        SetFreeCell 0, "", str, .TitleLeft / Screen.TwipsPerPixelX, .TitleTop / Screen.TwipsPerPixelY, _
                .TitleWidth / Screen.TwipsPerPixelX, .TitleHeight / Screen.TwipsPerPixelY, , True, .TitleAlign
    End With
End Sub
'加表头表尾
Private Sub AddHeadTail()
Dim intCount As Integer, intIndex As Integer
Dim lngTailTop As Long
Dim strName As String, strTitle As String
    With mclsCross
    '设置表头表尾
    intIndex = 1
    For intCount = 0 To .HeadColumns - 1
        Select Case .HeadFuncIndex(intCount)
        Case 0
            strName = .HeadDesc(intCount)
            strTitle = ""
        Case 1
            strName = mstrDateData
            strTitle = .HeadDesc(intCount) & ":"
        Case 5
            strName = mlngCurPage
            strTitle = .HeadDesc(intCount) & ":"
        Case Else
            strName = ReportFunc(.HeadFuncIndex(intCount))
            strTitle = .HeadDesc(intCount) & ":"
        End Select
        SetFreeCell intIndex, strTitle, strName, _
                    IIf(.HeadLeft(intCount) <> -1, .HeadLeft(intCount) / Screen.TwipsPerPixelX, intCount * 200 + 20), _
                    IIf(.HeadTop(intCount) <> -1, .HeadTop(intCount) / Screen.TwipsPerPixelY, GetGridTop - 30 - intIndex \ 3 * 18), _
                    IIf(.HeadWidth(intCount) <> -1, .HeadWidth(intCount) / Screen.TwipsPerPixelY, 150), _
                    IIf(.HeadHeight(intCount) <> -1, .HeadHeight(intCount) / Screen.TwipsPerPixelY, 15), , , _
                    .HeadAlign(intCount), True
        intIndex = intIndex + 1
    Next intCount
    ABook.GridBottom = clsFset.GPaperBorder(1) + 60
    For intCount = 0 To .TailColumns - 1
        Select Case .TailFuncIndex(intCount)
        Case 0
            strName = .TailDesc(intCount)
            strTitle = ""
        Case 1
            strName = mstrDateData
            strTitle = .TailDesc(intCount) & ":"
        Case 5
            strName = mlngCurPage
            strTitle = .TailDesc(intCount) & ":"
        Case Else
            strName = ReportFunc(.TailFuncIndex(intCount))
            strTitle = .TailDesc(intCount) & ":"
        End Select
        SetFreeCell intIndex, strTitle, strName, _
                    IIf(.TailLeft(intCount) <> -1, .TailLeft(intCount) / Screen.TwipsPerPixelX, intCount * 200 + 20), _
                    IIf(.TailTop(intCount) <> -1, .TailTop(intCount) / Screen.TwipsPerPixelX, GetGridheight + GetGridTop + 3), _
                    IIf(.TailWidth(intCount) <> -1, .TailWidth(intCount) / Screen.TwipsPerPixelY, 150), _
                    IIf(.TailHeight(intCount) <> -1, .TailHeight(intCount) / Screen.TwipsPerPixelY, 15), , , _
                    .TailAlign(intCount), False
        intIndex = intIndex + 1
    Next intCount
    End With
End Sub
'取日期数据
Private Sub GetDateStr()
Dim strTemp As String, strName As String
Dim strDate As String
    strTemp = GetNoXString(mstrDateCond, 7, "|")
    strName = StringOut(strTemp, ",")
    strDate = StringOut(strTemp, ",")
    If Trim(strTemp) <> "" Then
        strDate = StringOut(strTemp, ",")
        If strDate = "" Then
            mstrDateWhere = ""
            mstrDateData = "帐套启用日至今"
'            mstrDateData = Format(gclsBase.BaseDate, "YYYY-MM-DD") & "至" & Format(Date, "YYYY-MM-DD")
        Else
            mstrDateData = Format(strDate, "YYYY-MM-DD") & "--" & Format(strTemp, "YYYY-MM-DD")
            mstrDateWhere = strName & ">=#" & Format(strDate, "YYYY-MM-DD") & "# And " & strName & "<=#" & Format(strTemp, "YYYY-MM-DD") & "#"
        End If
    Else
        If strDate = "" Then
            mstrDateWhere = ""
            mstrDateData = "帐套启用日至今"
'            mstrDateData = Format(gclsBase.BaseDate, "YYYY-MM-DD") & "至" & Format(Date, "YYYY-MM-DD")
        Else
            mstrDateWhere = strName & "=#" & Format(strDate, "YYYY-MM-DD") & "#"
            mstrDateData = Format(strDate, "YYYY-MM-DD")
        End If
    End If
End Sub
'初始化GRID栏目标题
Private Sub InitTitle()
Dim intRow As Integer, intCol As Integer
Dim strTitle As String
Dim lngWidth As Long
    msgAccount.Redraw = False
    msgTitle.Redraw = False

    msgTitle.Cols = msgAccount.Cols
    msgTitle.FixedRows = mclsCross.ColColumns
    msgAccount.FixedCols = mclsCross.RowColumns
    msgTitle.FixedCols = msgAccount.FixedCols
    '对表头赋值
     For intCol = msgTitle.FixedCols To msgTitle.Cols - 1
        strTitle = msgAccount.TextMatrix(0, intCol)
        For intRow = 0 To msgTitle.FixedRows - 1
             msgTitle.TextMatrix(intRow, intCol) = GetNoXString(strTitle, intRow + 1, "/")
             msgTitle.RowHeight(intRow) = 225
        Next intRow
        msgTitle.FixedAlignment(intCol) = 4
     Next intCol
     For intRow = msgTitle.FixedRows To 3
         msgTitle.RowHeight(intRow) = 0
     Next intRow
     '合并性质
     msgAccount.MergeCells = flexMergeRestrictRows
     msgTitle.MergeCells = flexMergeRestrictColumns
     For intCol = 0 To msgTitle.FixedCols - 1
        For intRow = 0 To msgTitle.FixedRows - 1
            msgTitle.TextMatrix(intRow, intCol) = msgAccount.TextMatrix(0, intCol)
        Next intRow
        msgTitle.MergeCol(intCol) = True
     Next intCol
     For intCol = 0 To msgAccount.FixedCols - 1
        msgAccount.MergeCol(intCol) = True
     Next
    msgTitle.MergeRow(0) = True
    msgTitle.MergeRow(1) = True
    msgTitle.MergeRow(2) = True
    msgAccount.RowHeight(0) = 0
    For intCol = 0 To msgAccount.Cols - 1
        lngWidth = Len(msgTitle.TextMatrix(msgTitle.FixedRows - 1, intCol)) * 190 + 50
        If lngWidth > msgAccount.ColWidth(intCol) Then msgAccount.ColWidth(intCol) = lngWidth
    Next intCol
    
    msgAccount.Redraw = True
    msgTitle.Redraw = True
End Sub
'处理行列汇总
Private Sub DealRowColTotal()
Dim intRow As Integer, intCol As Integer
Dim sngTotal As Single
    '行合计
    If mclsCross.IsRowSum And mclsCross.RowTotalMethod > 0 Then
    msgTitle.Cols = msgAccount.Cols + 1
    msgAccount.Cols = msgTitle.Cols
        For intRow = 0 To msgTitle.FixedRows - 1
           msgTitle.TextMatrix(intRow, msgTitle.Cols - 1) = "合计"
        Next
        msgTitle.MergeCol(msgTitle.Cols - 1) = True
    Select Case mclsCross.RowTotalMethod
    Case 1   '求和
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = 0
           For intCol = msgTitle.FixedCols To msgTitle.Cols - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intRow
    Case 2    '平均
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = 0
           For intCol = msgTitle.FixedCols To msgTitle.Cols - 2
              sngTotal = sngTotal + Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal / (intCol - 1)
       Next intRow
    Case 3    '最小值
       For intRow = 1 To msgAccount.Rows - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, msgTitle.FixedCols))
           For intCol = msgTitle.FixedCols + 1 To msgTitle.Cols - 2
              If sngTotal > Val(msgAccount.TextMatrix(intRow, intCol)) Then _
                    sngTotal = Val(msgAccount.TextMatrix(intRow, intCol))
           Next intCol
           msgAccount.TextMatrix(intRow, intCol) = sngTotal
       Next intRow
    Case 4    '最大值
        For intRow = 1 To msgAccount.Rows - 1
           sngTotal = Val(msgAccount.TextMatrix(intRow, msgTitle.FixedCols))