frmardetail.frm

金算盘软件代码

    If KeyCode = 27 Then
        cmdClose_Click 0
    End If
End Sub

Private Sub Form_Load()
    MsgForm.PleaseWait
    With Me
        .width = 8370
        .Height = 6540
    End With
    RefreshLtxtCurrency
    RefreshltxtCustomer
    Set mclsList = New Grid
    mclsList.ListSet.ViewId = 653
    Set mclsList.Grid = msgARDetail
    Utility.LoadFormResPicture Me
    If frmSetTaskPara.ByDueDay Then
        Label1(2).Caption = "计算依据：到期日"
    Else
        Label1(2).Caption = "计算依据：开票日"
    End If
    Unload MsgForm
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    cmdClose(0).Left = ScaleWidth - cmdClose(0).width - mlngLeft
    cmdClose(1).Left = cmdClose(0).Left
    cmdClose(2).Left = cmdClose(0).Left

    With msgARDetail
        .width = cmdClose(0).Left - 2 * mlngLeft
        .Height = ScaleHeight - mlngTop - mlngBottom
    End With
End Sub

Private Sub Form_Unload(Cancel As Integer)
    On Error Resume Next

    If Not mrecCash Is Nothing Then
        Set mrecCash = Nothing
    End If
    Utility.UnLoadFormResPicture Me
    Set frmARDetail = Nothing
End Sub

Private Sub RefreshGrid()
    On Error Resume Next
    
    msgARDetail.FixedCols = 0
    If Not mclsList.Grid Is Nothing Then
        Set mclsList.Grid = Nothing
    End If
    mclsList.ColOfs = 2
    Set mclsList.Grid = msgARDetail
    'Set datAR.Recordset = GetARList()
    Set datAR.Resultset = GetARList()
    FindSpecialCol
    msgARDetail.ColWidth(1) = 0
    mclsList.SetupStyle
    mclsList.ListSetToGrid
    If frmSetTaskPara.ByARBalance Then
        GetCashDetail
        CashtoARDetail
    End If
    ShowTotalRow
    
    cmdClose(1).Enabled = (msgARDetail.Rows > msgARDetail.FixedRows)
    cmdClose(2).Enabled = (msgARDetail.Rows > msgARDetail.FixedRows)
End Sub

'从明细表中生成与当前单位、币种
'相应的应收单/财务费用单的应收资料
Private Function GetARList() As rdoResultset
    Dim strSql As String
    'Dim qryTemp As QueryDef
    Dim qryTemp As rdoQuery
    Dim strQARDetailSql As String
    
    On Error Resume Next
    
    mlngCustomerID = ltxtCustomer.ID
    mlngCurrencyID = ltxtCurrency.ID
    '参数查询QARDetail
'    strSql = strSql & "PARAMETERS ParaDate Date;"
'    strSql = strSql & " SELECT lngActivityID,lngReceiptTypeID," & mclsList.ListSet.SelectOfSql
'    strSql = strSql & " FROM QARDetail "
'    strSql = strSql & " WHERE lngCustomerID=" & mlngCustomerID _
'        & " AND lngCurrencyID=" & mlngCurrencyID & " AND dblCurrAmount>0"
'    If frmSetTaskPara.ByDueDay Then
'        strSql = strSql & " AND DateDiff('d',strDueDate,'" & mstrDate & "')>" & frmSetTaskPara.Days
'    Else
'        strSql = strSql & " AND DateDiff('d',strReceiptDate,'" & mstrDate & "')>" & frmSetTaskPara.Days
'    End If
'    '不计算复利
'    If Not frmSetTaskPara.Duplicate Then
'        strSql = strSql & " AND lngActivityTypeID<>38 "
'    End If
'    strSql = strSql & " ORDER BY strDate"
'    Set qryTemp = gclsBase.BaseDB.CreateQueryDef("", strSql)
'    With qryTemp
'        .Parameters("ParaDate") = CDate(mstrDate)
'        'Set GetARList = .OpenRecordset(dbOpenSnapshot)
'        Set GetARList = .OpenResultset(rdOpenStatic)
'    End With
    strQARDetailSql = TransferPublic.getQARDetailOraSql
    strSql = " SELECT lngActivityID,lngReceiptTypeID," & mclsList.ListSet.SelectOfSql
    strSql = strSql & " FROM ( " & strQARDetailSql & " ) QARDetail "
    strSql = strSql & " WHERE lngCustomerID=" & mlngCustomerID _
        & " AND lngCurrencyID=" & mlngCurrencyID & " AND dblCurrAmount>0"
    If frmSetTaskPara.ByDueDay Then
        strSql = strSql & " AND (TO_Date('" & mstrDate & " ','RRRR-MM-DD')-TO_DATE(strDueDate,'RRRR-MM-DD'))>" & frmSetTaskPara.Days
    Else
        strSql = strSql & " AND (TO_Date('" & mstrDate & " ','RRRR-MM-DD')-TO_DATE(strReceiptDate,'RRRR-MM-DD'))>" & frmSetTaskPara.Days
    End If
    '不计算复利
    If Not frmSetTaskPara.Duplicate Then
        strSql = strSql & " AND lngActivityTypeID<>38 "
    End If
    strSql = strSql & " ORDER BY strDate"
    strSql = UCase(strSql)
    strSql = Salary.Change_Text("[PARADATE]", "'" & Format(mstrDate, "YYYY-MM-DD") & "'", strSql)
    Set GetARList = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
    
End Function

Private Sub GetCashDetail()
    Dim strSql As String

    On Error Resume Next
    
    mlngCustomerID = ltxtCustomer.ID
    mlngCurrencyID = ltxtCurrency.ID
    
    '收款单（40），应收借项单体(36),应收贷项单头(36)
    strSql = "SELECT QARDetail.dblCurrAmount*(-1) As dblCurrAmount " _
        & "FROM QARDetail " _
        & "WHERE lngCustomerID=" & mlngCustomerID & " AND lngCurrencyID=" & mlngCurrencyID _
        & " AND QARDetail.dblCurrAmount<0 AND strReceiptDate<'" & mstrDate & "' "
    '不计算复利
    If Not frmSetTaskPara.Duplicate Then
        strSql = strSql & " AND lngActivityTypeID<>38 "
    End If
    'Set mrecCash = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set mrecCash = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Sub

Private Sub CashtoARDetail()
    Dim lngRow As Long
    Dim lngCnt As Long
    Dim dblCurrCashAmount As Double
    Dim dblCurrARAmount As Double

    If Not frmSetTaskPara.ByARBalance Then
        Exit Sub
    End If

    If mrecCash Is Nothing Then
        Exit Sub
    ElseIf mrecCash.EOF Then
        Exit Sub
    End If

    lngRow = 1
    mrecCash.MoveFirst
    dblCurrCashAmount = mrecCash!dblCurrAmount
    With msgARDetail
        Do While dblCurrCashAmount > 0
            dblCurrARAmount = GetValue(lngRow, mintColAmount)
            If dblCurrARAmount > dblCurrCashAmount Then
                .TextMatrix(lngRow, mintColAmount) = (dblCurrARAmount - dblCurrCashAmount)
                mclsList_AfterRefresh lngRow
                dblCurrCashAmount = 0
            Else
                .TextMatrix(lngRow, mintColAmount) = 0
                .RowHeight(lngRow) = 0
                dblCurrCashAmount = dblCurrCashAmount - dblCurrARAmount
            End If
            If dblCurrCashAmount = 0 Then
                mrecCash.MoveNext
                If Not mrecCash.EOF Then
                    dblCurrCashAmount = mrecCash!dblCurrAmount
                Else
                    Exit Do
                End If
            Else
                lngRow = lngRow + 1
                If lngRow >= .Rows Then
                    Exit Do
                End If
            End If
        Loop
        If lngRow < .Rows Then
            .Row = lngRow
        End If
    End With
End Sub

Private Sub ShowTotalRow()
    Dim lngRow As Long
    Dim dblCurrAmount As Double

    dblCurrAmount = 0
    For lngRow = 1 To msgARDetail.Rows - 1
        If msgARDetail.RowHeight(lngRow) > 100 Then
            dblCurrAmount = dblCurrAmount + GetValue(lngRow, mintColAmount)
        End If
    Next lngRow
    If dblCurrAmount <> 0 Then
        hLb(mintColAmount) = strFormat(dblCurrAmount, mintDec)
    Else
        hLb(mintColAmount) = ""
    End If
End Sub

'打印设置
Private Sub PrintDetail()
    Dim clsPrint As New PrintClass
    If msgARDetail.Rows > msgARDetail.FixedRows Then
        With msgARDetail
            .Rows = .Rows + 1
            .TextMatrix(.Rows - 1, 2) = "合计"
            .TextMatrix(.Rows - 1, mintColAmount) = hLb(mintColAmount)
        End With
        clsPrint.PrintList gclsBase.BaseDB, msgARDetail, 65, "财务费用应收资料列表" & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName & Chr(1) _
            & "单位：" & ltxtCustomer.Text & Chr(2) & "币种：" & ltxtCurrency.Text & Chr(2) & Label1(2).Caption
        msgARDetail.Rows = msgARDetail.Rows - 1
    End If
    Set clsPrint = Nothing
End Sub

Private Function GetValue(lngRow As Long, intCol As Integer, Optional strType As String = "Double") As Variant
    GetValue = GetGridValue(lngRow, intCol, strType, msgARDetail)
End Function

Private Sub RefreshltxtCustomer()
    Set ltxtCustomer.Recordset = Utility.GetListRecordSet(lrtCustomer)
End Sub

Private Sub RefreshLtxtCurrency()
    Dim strSql As String
    
    On Error Resume Next
    
    'strSql = "SELECT lngCurrencyID,strCurrencyCode,strCurrencyName " _
        & "FROM Currencys WHERE not blnIsInActive " _
        & " ORDER BY lngCurrencyID"
    strSql = "SELECT lngCurrencyID,strCurrencyCode,strCurrencyName " _
        & "FROM Currencys WHERE  blnIsInActive=0 " _
        & " ORDER BY lngCurrencyID"
    'Set ltxtCurrency.Recordset = gclsBase.BaseDB.OpenRecordset(strSql, dbOpenSnapshot)
    Set ltxtCurrency.Recordset = gclsBase.BaseDB.OpenResultset(strSql, rdOpenStatic)
End Sub

Private Sub ltxtCustomer_Choose()
    If mlngCustomerID <> ltxtCustomer.ID Then
        RefreshGrid
    End If
End Sub

Private Sub ltxtCurrency_Choose()
    If mlngCurrencyID <> ltxtCurrency.ID Then
        mintDec = CurrencyDec(ltxtCurrency.ID)
        RefreshGrid
    End If
End Sub

Private Sub FindSpecialCol()
    mintColAmount = GetGridCol("应收余额", msgARDetail)
End Sub

Private Sub mclsList_AfterColChange(lngSourCol As Long, lngDestCol As Long)
    FindSpecialCol
End Sub

Private Sub mclsList_AfterRefresh(lngRow As Long)
    With msgARDetail
        If mintColAmount > 0 Then
            .TextMatrix(lngRow, mintColAmount) = strFormat(C2Dbl(.TextMatrix(lngRow, mintColAmount)), mintDec)
            'Debug.Print .TextMatrix(lngRow, mintColAmount)
        End If
    End With
End Sub