frmagereport.frm

金算盘软件代码

    LSTCurrencys.TextMatrix(0, 1) = 0
    If mclsAgeSet.CurrencyID = 0 Then
        LSTCurrencys.ReferRow = 0 '  mclsAgeSet.CurrencyID
    Else
        Dim IndexRow As Long
        IndexRow = 2
        For IndexRow = 2 To LSTCurrencys.Referrows
            If Not IsNumeric(LSTCurrencys.TextMatrix(IndexRow, 1)) Then
                mclsAgeSet.CurrencyID = 0
                IndexRow = 0
                Exit For
            End If
            If LSTCurrencys.TextMatrix(IndexRow, 1) = mclsAgeSet.CurrencyID Then
                Exit For
            End If
        Next
        LSTCurrencys.ReferRow = IndexRow
    End If
    
'    If mclsAgeSet.IsGrouped Then
'        DealWithGroups          '只显示汇总:计算合计值
'    End If
    
    NewDisplayRowSumData
    
    If mclsAgeSet.IsGrouped Then
        DisplayRowPercent       '只显示汇总:计算行百分比
        If mclsAgeSet.HaveChooseZLTS Then CalcZLTS    '计算帐龄天数并恢复为计算帐龄天数的影响.
    End If
    
    AddTail
    SumARemain '计算余额
    
'    mintGroupCols = 0
'    For i = 0 To msgAccount.Cols - 2 'To 0 Step -1
'        If mbolColGrouped(i) Then
'            mintGroupCols = mintGroupCols + 1
'            DealWithGroupOrder (i)      '处理分组汇总
'        End If
'    Next i
    
    ChangeDataFormat            '改变显示格式:删除数据为 0 的行
    
    SetDataToBook               '将数据设置到真实报表
    mblnFormLoad = True
    Form_Resize
    Unload MsgForm
    Utility.LoadFormSetting Me
    Me.Visible = True
    mblnFatalErr = False
    mblnChanged = False
    Exit Sub
    
EndHandle:
    mblnFatalErr = True
    If Not (MsgForm Is Nothing) Then Unload MsgForm
    'ShowMsg Me.hwnd, "数据库中日期字段为非法日期表达式，请修改后再试！", vbOKOnly + vbCritical, "数据错误"
    Unload Me
    
End Sub


'获取已选字段数目
Private Function GetColNumber() As Integer
    Dim i As Integer
    Dim intCount As Integer
    
    intCount = 0
    For i = 0 To mclsAgeSet.ColNumber - 1
        If mclsAgeSet.ColIsChoosed(i) Then
            intCount = intCount + 1
        End If
    Next i
    GetColNumber = intCount
End Function

'初始化表体的行列值
Private Sub InitGridRowCol()
    Dim Index As Long
    Dim i As Long
    '增加 3 个字段，第一个为“合计”，第二个为“百分比”，第三个为“行标识”
    '*******************
    msgAccount.Cols = GetColNumber + mclsAgeSet.YearMonthNumber + mclsAgeSet.PeriodNumber * IIf(mclsAgeSet.IsGrouped, 2, 1) + 3
    
    For Index = msgAccount.Cols - 1 To msgAccount.Cols - mclsAgeSet.YearMonthNumber Step -1
        For i = 0 To msgAccount.Rows - 1
            msgAccount.TextMatrix(i, Index) = msgAccount.TextMatrix(i, Index - 2)
        Next
        msgAccount.ColWidth(Index) = 0        '标识列宽度设为 不可见
    Next
'    '增加 3 个字段，第一个为“合计”，第二个为“百分比”，第三个为“行标识”
'    msgAccount.Cols = GetColNumber + mclsAgeSet.PeriodNumber * IIf(mclsAgeSet.IsGrouped, 2, 1) + 3
    
    msgAccount.ColWidth(msgAccount.Cols - 1) = 0        '标识列宽度设为 不可见
    ReDim mbytColType(msgAccount.Cols)
    ReDim mbolColGrouped(msgAccount.Cols)
End Sub


Private Sub Form_Unload(Cancel As Integer)
Dim intType As Integer
    On Error Resume Next
   If mblnChanged And Not mblnFatalErr Then
        intType = Utility.ShowMsg(Me.hWnd, "报表[" & Me.Caption & "]已改变,是否保存？", vbYesNoCancel + vbQuestion, App.title)
        If intType = vbYes Then
            cmdSave_Click
        ElseIf intType = vbCancel Then
            Cancel = True
            gblnCancel = True
            Exit Sub
        End If
   End If
    gclsSys.MainControls.Remove Me
    Set mclsAgeSet = Nothing
    Set mclsMainControl = Nothing
    Set ABook = Nothing
    Set mFont = Nothing
    If Not (MsgForm Is Nothing) Then Unload MsgForm
    Erase mcurSumData()
    Erase mbytColType()
    Erase mstrGraphics()
    Erase mlngColStart()
    Erase mlngColEnd()
    Erase mlngRowStart()
    Erase mlngRowEnd()
    Erase mlngEndRowTop()
    Erase mblnRowHaveData()
    Erase mbolColGrouped()
    Erase mintPos()
    Erase mvarPeriodPerWidth()
End Sub
'计算应收（应付）余额
Private Sub SumARemain()
    Dim lngRows As Long
    Dim lngCols As Long
    Dim lngRowIndex As Long
    Dim lngColIndex As Long
    Dim blnHasRemainCol As Boolean
    Dim lngCurrCol As Long ' 原币余额所在的行
    Dim lngCol As Long '本币余额所在的行
    lngRows = msgAccount.Rows - 2 '减去增加的两行
    lngCols = msgAccount.Cols
    lngCurrCol = -1
    lngCol = -1
    If lngRows = 1 Then Exit Sub '没有数据退出
    '寻找余额所在的列
    For lngColIndex = msgAccount.FixedCols To lngCols - 1
        If Right(msgAccount.TextMatrix(0, lngColIndex), 2) = "余额" Then
            If Left(msgAccount.TextMatrix(0, lngColIndex), 2) = "原币" Then
                lngCurrCol = lngColIndex
            ElseIf Left(msgAccount.TextMatrix(0, lngColIndex), 2) = "本币" Then
                lngCol = lngColIndex
            End If
        End If
    Next
    If lngCurrCol <> -1 Then
        FillARemain lngCurrCol
    End If
    If lngCol <> -1 Then
        FillARemain lngCol
    End If
End Sub
Private Sub FillARemain(ByVal lngCol As Long)
    Dim lngRows As Long
    Dim lngRowIndex As Long
    Dim dblLastData As Double
    lngRows = msgAccount.Rows - 2 '减去增加的两行
    dblLastData = IIf(msgAccount.TextMatrix(1, lngCol) = "", 0, CDbl(msgAccount.TextMatrix(1, lngCol))) '初始值为第一行的数据
    '从第二行开始计算
    For lngRowIndex = 2 To lngRows - 1
        If msgAccount.TextMatrix(lngRowIndex, lngCol) <> "" Then
            msgAccount.TextMatrix(lngRowIndex, lngCol) = dblLastData + CDbl(msgAccount.TextMatrix(lngRowIndex, lngCol))
        Else
            msgAccount.TextMatrix(lngRowIndex, lngCol) = dblLastData
        End If
        dblLastData = msgAccount.TextMatrix(lngRowIndex, lngCol)
    Next
End Sub


'计算各列合计值和百分比并显示
Private Sub AddTail()
    Dim i, j As Long 'Integer
    Dim intIndex As Long 'Integer
    Dim dblSum() As Double
    Dim dblPercent() As Double
    Dim intPos As Long 'Integer
    With msgAccount
        intIndex = .Rows
        ReDim dblSum(.Cols)
        ReDim dblPercent(.Cols)
        
        .AddItem "", intIndex
        .RowHeight(intIndex) = lngTailHeight
        
        For i = 0 To .Cols - 2      '第一个区间字段的列号
            If mbytColType(i) = 1 Then
                intPos = i - 1
                Exit For
            Else
                .TextMatrix(intIndex, i) = "合 计 "
                .Row = intIndex
                .col = intPos
                .CellAlignment = flexAlignRightCenter
                .CellBackColor = .BackColorFixed ' vbButtonFace
                .CellForeColor = .ForeColorFixed ' vbBlue
            End If
        Next i
        
        For i = 0 To .Cols - 2
            dblSum(i) = 0
            If mbytColType(i) = 1 Then        '区间字段
                For j = 1 To intIndex
                    If .TextMatrix(j, i) <> "" Then
                        dblSum(i) = dblSum(i) + Val(.TextMatrix(j, i))
                    End If
                Next j
            .TextMatrix(intIndex, i) = str(dblSum(i)) ', "###,###,###,##0.00")
            .col = i
            .Row = intIndex
            .CellBackColor = .BackColorFixed ' vbButtonFace
            .CellForeColor = .ForeColorFixed ' vbBlue
            End If
            
        Next i
        
        For i = 1 To .Cols - 2
            If mbytColType(i) = 2 Then          '百分比字段
                If mcurSumAll = 0 Then
                    dblPercent(i) = 0
                    .TextMatrix(intIndex, i) = "0"
                Else
                   dblPercent(i) = dblSum(i - 1) / mcurSumAll * 100
                   .TextMatrix(intIndex, i) = str(dblPercent(i)) ', "##0.00")
                   .col = i
                   .Row = intIndex
                   .CellBackColor = .BackColorFixed ' vbButtonFace
                   .CellForeColor = .ForeColorFixed ' vbBlue
                End If
    
            End If
        Next i
        
        If intPos > 0 Then                  '合并列
            .MergeCells = flexMergeRestrictRows
            'flexMergeRestrictAll ' = flexMergeFree ' ' = =  flexMergeRestrictColumns '
            For i = 0 To intPos
                .MergeCol(i) = True
            Next i
            For i = 0 To .Rows - 1
                .MergeRow(i) = False
            Next i
            .MergeRow(intIndex) = True
        End If
        
        .TextMatrix(intIndex, .Cols - 3) = str(mcurSumAll) ', "###,###,###,##0.00")    '总和
        .col = .Cols - 3
        .Row = intIndex
        .CellBackColor = .BackColorFixed ' vbButtonFace
        .CellForeColor = .ForeColorFixed ' vbBlue
        
        If mcurSumAll <> 0 Then
            .TextMatrix(intIndex, .Cols - 2) = "100.0"    '总和百分比
        Else
            .TextMatrix(intIndex, .Cols - 2) = ""
        End If
        
        .col = .Cols - 1
        .Row = intIndex
        .CellBackColor = .BackColorFixed ' vbButtonFace
        .CellForeColor = .ForeColorFixed ' vbBlue
        
        If Not mclsAgeSet.IsGrouped Then            '显示明细数据时调用
            .AddItem "", intIndex + 1
            .RowHeight(intIndex + 1) = lngTailHeight
            
            For i = 0 To intPos
                .TextMatrix(intIndex + 1, i) = "百分比 [%] "
                .Row = intIndex + 1
                .col = intPos
                .CellAlignment = flexAlignRightCenter
                .CellBackColor = .BackColorFixed ' vbButtonFace
                .CellForeColor = .ForeColorFixed ' vbBlue
            Next i
            
            For i = 1 To .Cols - 1
                If mbytColType(i) = 1 Then
                    .TextMatrix(intIndex + 1, i) = str(dblPercent(i + 1)) ', "##0.00")
                    .col = i
                    .CellBackColor = .BackColorFixed ' vbButtonFace
                    .CellForeColor = .ForeColorFixed ' vbBlue
                End If
            Next i
            .TextMatrix(intIndex, .Cols - 2) = ""
            
            If mcurSumAll <> 0 Then
                .TextMatrix(intIndex + 1, .Cols - 2) = "100.0"
            Else
                .TextMatrix(intIndex + 1, .Cols - 2) = ""
            End If
            
            .col = .Cols - 2
            .CellBackColor = .BackColorFixed ' vbButtonFace
            .CellForeColor = .ForeColorFixed ' vbBlue
            For i = 0 To .Rows - 1
                .MergeRow(i) = False
            Next i
            .MergeRow(intIndex) = True
            .MergeRow(intIndex + 1) = True
        End If
        .FixedCols = intPos + 1
    End With
End Sub


'计算帐龄天数
Private Sub CalcZLTS()
    Dim i, j As Long 'Integer
    Dim ColZLQJ As Long
    Dim DblSumTemp As Double
    Dim dblQJSumAmount As Double
    Dim strDatetemp As String
    Dim intDateType As Integer
    'strDueDate", AgeStartDate
    If UCase(mclsAgeSet.AgeStartDate) = "STRDUEDATE" Then
        intDateType = 0
    Else
        intDateType = 1
    End If
    With msgAccount
        For i = 0 To msgAccount.Cols - mclsAgeSet.YearMonthNumber - 3
            If .TextMatrix(0, i) = "应收帐龄天数" Then
                ColZLQJ = i
                Exit For
            End If
        Next
        For i = 1 To .Rows - 1
            DblSumTemp = .TextMatrix(i, msgAccount.Cols - mclsAgeSet.YearMonthNumber - 3)
            If DblSumTemp > 0 Then
                For j = msgAccount.Cols - 1 To msgAccount.Cols - mclsAgeSet.YearMonthNumber Step -1
                    dblQJSumAmount = IIf(IsNumeric(.TextMatrix(i, j)), .TextMatrix(i, j), 0)
                    DblSumTemp = DblSumTemp - dblQJSumAmount
                    If DblSumTemp <= 0 Then
                        Exit For
                    End If
                Next
                If j = msgAccount.Cols - 1 Then
'                    If intDateType = 0 Then
'                        .TextMatrix(i, ColZLQJ) = CInt((CDate(mclsAgeSet.AgeEndDate) - CDate(mclsAgeSet.AgeEndDate))) - TermDays(i)
'                    Else
                        .TextMatrix(i, ColZLQJ) = CInt((CDate(mclsAgeSet.AgeEndDate) - CDate(Format(mclsAgeSet.AgeEndDate, "yyyy-mm") & "-1")))
'                    End If
                Else
                    If DblSumTemp < 0 Then
                        strDatetemp = Format(DateAdd("m", 1, CDate(.TextMatrix(0, j))), "yyyy-mm-dd")
'                        If