frmfinancereport.frm

金算盘软件代码

                If strCurr = strTemp And intRowIndex >= intRows Then
                    dblAnalyData(intArrRow, intColIndex) = Format(dblTempSum, "##,##0.00")
                    dblTempSum = 0
                End If
            End If
        Next
    End If
    dblTempSum = 0
    For intArrCol = 0 To ArrCols
        For intArrRow = 0 To ArrRows
            dblTempSum = dblAnalyData(intArrRow, intArrCol) + dblTempSum
        Next
        dblAnalySum(intArrCol) = dblTempSum
        For intArrRow = 0 To ArrRows
            If dblAnalySum(intArrCol) <> 0 Then
                dblAnalyData(intArrRow, intArrCol) = CDbl(Format(dblAnalyData(intArrRow, intArrCol) / dblAnalySum(intArrCol) * 100, "0.00"))
            End If
        Next
        dblTempSum = 0
    Next
    '将生成的数据添加到网格中去
    Dim strGridItem As String
    Dim intStartRow As Integer
    Dim strFindString As String
    Dim strHead As String
    grdAcntBook.Row = 0
    grdAcntBook.col = 0
    strHead = grdAcntBook.Text
    grdAcntBook.Row = 1
    If Trim(strHead) = "科目" Then
        strFindString = Left(grdAcntBook.Text, 3)
    Else
        strFindString = grdAcntBook.Text
    End If
    intStartRow = 1
    strGridItem = ""
    For intRowIndex = 0 To ArrRows - 1
        For intColIndex = 0 To ArrCols - 1
            If strGridItem = "" Then
                strGridItem = strFindString & "占比(%)" & Vbtabs(intDataBeginCol) & dblAnalyData(intRowIndex, intColIndex)
            Else
                strGridItem = strGridItem & vbTab & dblAnalyData(intRowIndex, intColIndex)
            End If
        Next
        LocateRow intStartRow, strHead, strFindString
        grdAcntBook.AddItem strGridItem, intStartRow
        intStartRow = intStartRow + 1
        strGridItem = ""
    Next
    strGridItem = ""
    For intColIndex = 0 To ArrCols
        If strGridItem = "" Then
            strGridItem = strHead & "合计" & Vbtabs(intDataBeginCol) & dblAnalySum(intColIndex)
        Else
            strGridItem = strGridItem & vbTab & dblAnalySum(intColIndex)
        End If
    Next
    grdAcntBook.AddItem strGridItem
End Sub

'计算要添加的行的位置
Private Function LocateRow(intStartRow As Integer, ByVal strHeadTitle As String, FindString As String) As Integer
    Dim intRowIndex As Integer
    Dim intRows As Integer
    Dim strGridText As String
    Dim strTemp As String
    intRows = grdAcntBook.Rows
    grdAcntBook.col = 0
    grdAcntBook.Row = intStartRow
    strGridText = grdAcntBook.Text
    If strHeadTitle = "科目" Then
        strGridText = Left(strGridText, 3)
        For intRowIndex = intStartRow To intRows - 1
            grdAcntBook.Row = intRowIndex
            strTemp = Left(grdAcntBook.Text, 3)
            If strTemp <> FindString Then
                intStartRow = intRowIndex
                FindString = strTemp
                Exit For
            End If
        Next
        If FindString = strTemp And intRowIndex >= intRows Then
            intStartRow = intRows
        End If
    Else
        For intRowIndex = intStartRow To intRows - 1
            grdAcntBook.Row = intRowIndex
            strTemp = grdAcntBook.Text
            If strTemp <> FindString Then
                intStartRow = intRowIndex
                FindString = strTemp
                Exit For
            End If
        Next
        If FindString = strTemp And intRowIndex >= intRows Then
            intStartRow = intRows
        End If
    End If
End Function

'计算每行中的分隔符数(根据固定列数)
Private Function Vbtabs(ByVal intVbtabs As Integer) As String
    Dim intCount As Integer
    Dim strVbtabs As String
    strVbtabs = ""
    For intCount = 1 To intVbtabs
        If strVbtabs = "" Then
            strVbtabs = vbTab
        Else
            strVbtabs = strVbtabs & vbTab
        End If
    Next
    Vbtabs = strVbtabs
End Function

'清零,将表格中所有为"0"的单元置为""(空)
Private Sub ClearZero()
    Dim intRows As Integer
    Dim intCols As Integer
    Dim intRowIndex As Integer
    Dim intColIndex As Integer
    Dim intDataCol As Integer
    Dim dblText As Double
    intRows = grdAcntBook.Rows
    intCols = grdAcntBook.Cols
    intDataCol = mclsFinanceReport.Columns
    For intColIndex = intDataCol To intCols - 1
        grdAcntBook.col = intColIndex
        For intRowIndex = 1 To intRows - 1
            grdAcntBook.Row = intRowIndex
            If grdAcntBook.TextMatrix(intRowIndex, intColIndex) = "0" Then
                grdAcntBook.TextMatrix(intRowIndex, intColIndex) = ""
            ElseIf grdAcntBook.TextMatrix(intRowIndex, intColIndex) <> "0" Then
                dblText = CDbl(grdAcntBook.TextMatrix(intRowIndex, intColIndex))
                grdAcntBook.TextMatrix(intRowIndex, intColIndex) = Format(dblText, "##,##0.00")
            End If
        Next
    Next
End Sub

Private Sub grdAcntBook_DblClick()
    MsgBox grdAcntBook.Row
End Sub

'当报表重新设置后,由于要进行纵向分析,需要将那些置为空的单元重新置为"0",否则,就会出现类型不匹配的问题
Private Sub AddZero()
    Dim intRows As Integer
    Dim intCols As Integer
    Dim intRowIndex As Integer
    Dim intColIndex As Integer
    Dim intDataCol As Integer
    intRows = grdAcntBook.Rows
    intCols = grdAcntBook.Cols
    intDataCol = mclsFinanceReport.Columns
    For intColIndex = intDataCol To intCols - 1
        grdAcntBook.col = intColIndex
        For intRowIndex = 1 To intRows - 1
            grdAcntBook.Row = intRowIndex
            If grdAcntBook.Text = "" Then
                grdAcntBook.Text = "0"
            End If
        Next
    Next
End Sub
'初始化与期间有关的ListText
Private Sub ShowFilter()
    Dim intCount As Integer
    cmbAnalyDate.ClearRefer
    cmbReferDate.ClearRefer
    txtReportPeriod.ClearRefer
    Utility.InitDate cmbAnalyDate
    Utility.InitDate cmbReferDate
    txtReportPeriod.AddRefer "年" & vbTab & "0", 0, 1
    txtReportPeriod.AddRefer "季" & vbTab & "1", 1, 1
    txtReportPeriod.AddRefer "月" & vbTab & "2", 2, 1
    txtReportPeriod.AddRefer "期" & vbTab & "3", 3, 1
    txtReportPeriod.AddRefer "周" & vbTab & "4", 4, 1
End Sub

Private Sub grdAcntBook_Scroll()
    grdTitle.Cols = grdAcntBook.Cols
    If grdTitle.LeftCol <> grdAcntBook.LeftCol Then
        grdTitle.LeftCol = grdAcntBook.LeftCol
        CoverTail
    End If
End Sub

Private Sub grdTitle_Scroll()
    grdTitle.Cols = grdAcntBook.Cols
    If grdAcntBook.LeftCol <> grdTitle.LeftCol Then
        grdAcntBook.LeftCol = grdTitle.LeftCol
    End If
End Sub

Private Sub ReferBeginDate_LostFocus()
    If ReferBeginDate.Text = "" Then
        MsgBox "请输入一个日期!", vbExclamation
    End If
    If ReferBeginDate.Value > ReferEndDate.Value Then
        MsgBox "请输入小于截止时间的日期!", vbExclamation
    ElseIf ReferEndDate.Text = "" Then
        ReferEndDate.SetFocus
    Else
        mblnIsPeriodChanged = True
        If mblnResponseChange = False And CDate(ReferBeginDate.Text) <> CDate(mclsFinanceReport.DateBegin1) Then
            cmbReferDate_Choose
            cmbReferDate.Text = "自定义"
        End If
        mblnResponseChange = False
    End If
End Sub

Private Sub ReferEndDate_LostFocus()
    If ReferEndDate.Text = "" Then
        MsgBox "请输入一个日期!", vbExclamation
    End If
    If ReferBeginDate.Value > ReferEndDate.Value Then
        MsgBox "请输入小于截止时间的日期!", vbExclamation
    ElseIf ReferBeginDate.Text = "" Then
        ReferBeginDate.SetFocus
    Else
        mblnIsPeriodChanged = True
        If mblnResponseChange = False And CDate(ReferEndDate.Text) <> CDate(mclsFinanceReport.DateEnd1) Then
            cmbReferDate_Choose
            cmbReferDate.Text = "自定义"
        End If
        mblnResponseChange = False
    End If
End Sub

Private Sub txtReportPeriod_Choose()
    Dim intResponseID As Integer
    If mblnFirstChange = True Or mblnReportReset = True Or mblnJustChooseWeek = True Or txtReportPeriod.Text = mclsFinanceReport.RptPeriod Then
        mblnJustChooseWeek = False
        Exit Sub
    End If
    mstrCodeID = txtReportPeriod.TextMatrix(txtReportPeriod.ReferRow, 1)
    mstrKeyName = txtReportPeriod.Text
    If Trim(mstrKeyName) = "周" Then
        intResponseID = MsgBox("你选择了""周""作为报告期,由于数据量很大,可能会造成数据的溢出," & Chr(13) & "继续吗?", vbYesNo + vbQuestion)
        If intResponseID = 7 Then
            mblnJustChooseWeek = True
            txtReportPeriod.Text = mclsFinanceReport.RptPeriod
            Exit Sub
        Else
            mblnIsPeriodChanged = True
            mblnErrHappened = True
            UpdateCond "ReportPeriod"
        End If
    Else
        mblnIsPeriodChanged = True
        UpdateCond "ReportPeriod"
    End If
End Sub

'当在报表上对期间进行修改后,需要将这些条件先存入数据库中,以便生成新的SQL语句
Private Sub UpdateCond(ByVal strClickType As String)
    Dim Strsql As String
    Dim rs As rdoResultset
    Dim strNewSelect As String
    Select Case strClickType
        Case "AnalyPeriod"
            Strsql = "DELETE * FROM ReportCond WHERE ReportCond.lngReportID = " & mlngReportID & _
                    " AND ( ReportCond.lngViewFieldID = " & mclsFinanceReport.AnalyViewFieldID & ")"                                   ' & mclsFinanceReport.AnalyViewFieldID
            gclsBase.BaseDB.Execute Strsql, dbFailOnError
            Set rs = gclsBase.BaseDB.OpenRecordset("ReportCond")
            With rs
                .AddNew
                    !lngReportId = mlngReportID
                    !strPath = "分析期"
                    !lngViewFieldID = mclsFinanceReport.AnalyViewFieldID                    ' mclsFinanceReport.AnalyViewFieldID
                    !strDateOp = mstrAnalyDateOP
                    !dtmDate1 = mdtmAnalyDate1
                    !dtmDate2 = mdtmAnalyDate2
                .Update
                .Close
            End With
        Case "ReferPeriod"
            Strsql = "DELETE * FROM ReportCond WHERE ReportCond.lngReportID = " & mlngReportID & _
                    " AND (ReportCond.lngViewFieldID = " & mclsFinanceReport.ReferViewFieldID & ") "                                      '& mclsFinanceReport.ReferViewFieldID
            gclsBase.BaseDB.Execute Strsql, dbFailOnError
            Set rs = gclsBase.BaseDB.OpenRecordset("ReportCond")
            With rs
                .AddNew
                    !lngReportId = mlngReportID
                    !strPath = "比较期"
                    !lngViewFieldID = mclsFinanceReport.ReferViewFieldID                    'mclsFinanceReport.ReferViewFieldID
                    !strDateOp = mstrReferDateOP
                    !dtmDate1 = mdtmReferDate1
                    !dtmDate2 = mdtmReferDate2
                .Update
                .Close
            End With
        Case "ReportPeriod"
            Strsql = "DELETE * FROM ReportCond WHERE ReportCond.lngReportID = " & mlngReportID & _
                    " AND (ReportCond.lngViewFieldID = " & mclsFinanceReport.ReportViewFieldID & ")"                                       '& mclsFinanceReport.ReportViewFieldID
            gclsBase.BaseDB.Execute Strsql, dbFailOnError
            Set rs = gclsBase.BaseDB.OpenRecordset("ReportCond")
            With rs
                .AddNew
                    !lngReportId = mlngReportID
                    !strPath = "报告期"
                    !lngViewFieldID = mclsFinanceReport.ReportViewFieldID                                    'mclsFinanceReport.ReportViewFieldID
                    !strString1 = mstrCodeID
                .Update
                .Close
            End With
    End Select
    strNewSelect = mclsFinanceReport.GetSelect(mclsFinanceReport.AccountTypeID)
    Me.Hide
    RefreshData (strNewSelect)
    Me.Show
End Sub

'初始化标题表格
Private Sub InitTitle()
    Dim intRows As Integer
    Dim intCols As Integer
    Dim lngPerRowHeight As Long
    Dim intRowIndex As Integer
    Dim intColIndex As Integer
    Dim intBeginCol As Integer
    intBeginCol = mclsFinanceReport.Columns
    intRows = grdAcntBook.Rows
    grdAcntBook.Row = 0
    grdAcntBook.col = 0
    'grdAcntBook的位置
    If grdAcntBook.Rows <= 1 Then
        grdAcntBook.Rows = 2
    End If
    grdAcntBook.FixedRows = 0
    grdTitle.Rows = 3
    grdTitle.FixedRows = 2
    grdTitle.Cols = grdAcntBook.Cols
    grdTitle.FixedCols = grdAcntBook.FixedCols
    grdTitle.MergeCells = flexMergeRestrictAll
    grdTitle.MergeRow(0) = True
    grdTitle.MergeRow(1) = True
    For intColIndex = 0 To grdTitle.Cols - 1
        grdTitle.ColWidth(intColIndex) = grdAcntBook.ColWidth(intColIndex)
    Next
    For intColIndex = 0 To intBeginCol - 1
        grdTitle.MergeCol(intColIndex) = True
        grdAcntBook.MergeCol(intColIndex) = True
    Next
    For intColIndex = 0 To grdTitle.Cols - 1