frmlisttrans.frm

金算盘软件代码

    Dim blnFlage As Boolean
   '执行过滤
    If mclsList.ListSet.ListID < 1 Then mclsList.ListSet.SaveList
    Filter.ShowFilter mclsList.ListSet.ListID, 1, , , , , blnFlage
    If Not blnFlage Then Exit Sub
    grdList.Redraw = False
    mclsList.SaveListSet
    mclsList.ListSet.ViewId = intViewID
    grdList.Cols = 0
    Set datGrid.Resultset = GetList()
    If Not datGrid.Resultset.EOF Then datGrid.Resultset.MoveLast
    datGrid.Resultset.Close
    mclsList.SetFlexGrid
    UpdateMenuStatus
    '初始化查找复合列表框
    mclsList.InitcboFindKind
    mclsList.DoShowAll True
    
    With grdList
        If .Rows > 1 Then
            .Row = 1
            .col = 1
            .ColSel = .Cols - 1
        End If
    End With
    grdList.Redraw = True
End Sub

'刷新
Private Sub mclsMainControl_ToolRefresh()
    Dim strOldText As String
    Dim strOldSort As String
    
    Me.MousePointer = vbHourglass
    With grdList
        '保存当前排序列
        strOldSort = cboFindKind.Text
        strOldText = .TextMatrix(.Row, mclsList.SortCol)
        .Redraw = False
        '刷新列表记录
        .FixedCols = 0
        Set datGrid.Resultset = GetList()
        mclsList.SetFlexGrid
        '恢复以前排序列
        cboFindKind.Text = strOldSort
        .Redraw = False
        If .Rows > 1 Then
            txtFind.Text = strOldText
        End If
        
        '更新菜单状态
        UpdateMenuStatus
        .Redraw = True
        
        If .Rows > 1 Then
            .Row = 1
            .col = 1
            .ColSel = .Cols - 1
        End If
    End With
    
    Me.MousePointer = vbDefault
End Sub

Private Sub mclsMainControl_FilePrint()
    Dim myPrintclass As PrintClass
    Set myPrintclass = New PrintClass
    myPrintclass.PrintList gclsBase.BaseDB, mclsList.FlexGrid, 51, Me.Caption & Chr(1) & gclsBase.BaseName & Chr(1) & gclsBase.OperatorName '通用转帐               51
End Sub

'
' 转帐菜单
'
Private Sub MakeListReportMenu()
    Dim intCnt As Integer
  
    With frmMain
        For intCnt = .mnuListReportMenu.Count - 1 To 1 Step -1
            Unload .mnuListReportMenu(intCnt)
        Next
        
        .mnuListReportMenu(0).Caption = "全部选择"
        .mnuListReportMenu(0).Enabled = True
        .mnuListReportMenu(0).Visible = True
        .mnuListReportMenu(0).Checked = False
        
         Load .mnuListReportMenu(1)
        .mnuListReportMenu(1).Caption = "全部取消"
        .mnuListReportMenu(1).Enabled = True
        .mnuListReportMenu(1).Visible = True
        .mnuListReportMenu(1).Checked = False
        
         Load .mnuListReportMenu(2)
        .mnuListReportMenu(2).Caption = "-"
        .mnuListReportMenu(2).Enabled = True
        .mnuListReportMenu(2).Visible = True
        .mnuListReportMenu(2).Checked = False
        
         Load .mnuListReportMenu(3)
        .mnuListReportMenu(3).Caption = "执行转帐"
        .mnuListReportMenu(3).Enabled = True
        .mnuListReportMenu(3).Visible = True
        .mnuListReportMenu(3).Checked = False
         
         Load .mnuListReportMenu(4)
        .mnuListReportMenu(4).Caption = "取消转帐"
        .mnuListReportMenu(4).Enabled = True
        .mnuListReportMenu(4).Visible = True
        .mnuListReportMenu(4).Checked = False
    End With
End Sub

Private Sub mclsMainControl_ListReportMenu(ByVal intIndex As Integer)
    Select Case intIndex
    Case 0: '全部选择
        mclsMainControl_DO 0
    Case 1: '全部取消
        mclsMainControl_DO 1
    Case 3: '执行转帐
        mclsMainControl_DO 3
    Case 4: '取消转帐
        mclsMainControl_DO 4
        
    End Select
End Sub

Private Sub mclsMainControl_DO(intReportType As Integer)
    Dim i As Integer
        
    Select Case intReportType
    Case 0:  '全部选择
        With grdList
            For i = 1 To .Rows - 1
                .TextMatrix(i, 1) = "√"
            Next i
        End With
    Case 1:  '全部取消
         With grdList
            For i = 1 To .Rows - 1
                .TextMatrix(i, 1) = ""
            Next i
        End With
    Case 3:  '执行转帐
        If IsCanDo(frmRightsID.doTransID) = False Then '判断有无编辑权限
            cMsgBox "您没有执行转帐的权限！"
            Exit Sub
        End If
        DoTrans
    Case 4:  '取消转帐
        If IsCanDo(frmRightsID.doTransID) = False Then '判断有无编辑权限
            cMsgBox "您没有取消转帐的权限！"
            Exit Sub
        End If
        DoCancelTrans
    End Select
End Sub

Public Sub RefreshList(theCurrentID As Long)
    Dim i As Long
    mclsMainControl_ToolRefresh
    
   '将当前行设置到刷新后的ID=theCurrentID的行
    With grdList
        For i = 1 To .Rows - 1
            If CLng(.TextMatrix(i, 0)) = theCurrentID Then
                theEditRow = i
                GotoRow (i)
                Exit For
            End If
        Next i
    End With
End Sub

'告诉列表：编辑窗口已关闭
Public Sub IAmCLosed()
    mIsShowEdit = False
End Sub



'////////////////////////////////////////////////////////////////////////////////////////////
'/
'/                                  功能实现
'/
'////////////////////////////////////////////////////////////////////////////////////////////

'保存转帐顺序
Private Sub SaveOrder()
  Dim i As Integer
  Dim lngTransVoucherID As Long
  Dim strSql As String
  
    With grdList
        For i = 1 To .Rows - 1
            lngTransVoucherID = CLng(.TextMatrix(i, 0))
            strSql = "UPDATE TransVoucher SET TransVoucher.intTransVoucherNO = " & i & " WHERE TransVoucher.lngTransVoucherID=" & lngTransVoucherID
            gclsBase.ExecSQL strSql
        Next i
    End With
End Sub

Private Sub AddAccount(ByVal lngID As Long, ByVal intDirect As Integer)
  Dim strCode As String
   On Error GoTo ErrHandle
      strCode = mcolAccount.Item(CStr(lngID))
      If intDirect = 1 Then
         If mstrDebit = "" Then
            mstrDebit = strCode
         Else
            mstrDebit = mstrDebit & " " & strCode
         End If
      Else
         If mstrCredit = "" Then
            mstrCredit = strCode
         Else
            mstrCredit = mstrCredit & " " & strCode
         End If
      End If
ErrHandle:
End Sub

'执行转帐
Private Sub DoTrans()
    Dim strSql As String
    Dim recTemp As rdoResultset
    Dim recTemp_Trans As rdoResultset
    Dim recTemp_1 As rdoResultset
    Dim lngTransVoucherID As Long
    
    Dim i As Integer
    Dim j As Integer
    Dim intCount As Integer
    Dim strMsg As String
    
    Dim strTransVoucherName As String
    Dim strFrequency As String
    Dim lngVoucherID As Long   '凭证ID
    Dim intLastVoucherNo As Long   '凭证No
    Dim colVoucherNo As Collection  '转帐ID对应的上次生成的凭证号
    Dim colDelVoucherNo As Collection  '转帐ID对应的上次生成且本次已删除的凭证号
    Dim intLastNo As Integer
    Dim intDelNo As Integer
    Dim lngVoucherDetailID As Long
    Dim intYear_Last As Integer '最后生成的转帐凭证对应的时间
    Dim bytPeriod_Last As Integer
    Dim intYear As Integer
    Dim bytPeriod As Integer
    Dim blnExisted As Boolean
    
    Dim intVoucherNO As Long
    Dim arrGenCancel() As Long '保存要生成冲销凭证的的凭证ID
    Dim arrDelVoucher() As Long
    Dim recTemp_Write As rdoResultset '往临时表--TransTemp添加数据的记录集
    Dim blnFound As Boolean
    Const lngVoucherSourceID = 16 '通用转帐
    
    '存储某条转帐模板中对应的转入、转出科目
    Dim arrlngAccountID_OUT() As Long
    Dim arrlngAccountid_IN() As Long
    
    Dim lngAccountID_Temp As Long
    Dim arrlngAccountID() As Long '保存某条转帐模板中的转出科目生成的凭证明细的科目
    Dim arrintDirection() As Integer '借贷方向
    Dim arrdblSumAmount() As Double
    Dim arrdblSumCurrency() As Double
    Dim arrdblSumQuantity() As Double
    '贷
    Dim dblSumAmount_D As Double
    Dim dblSumCurrency_D As Double
    Dim dblSumQuantity_D As Double
    '借
    Dim dblSumAmount_J As Double
    Dim dblSumCurrency_J As Double
    Dim dblSumQuantity_J As Double
    
    Dim dblSumAmount As Double
    Dim dblSumCurrency As Double
    Dim dblSumQuantity As Double
    
    Dim blnLoopEnd As Boolean
    Dim intArrNo As Integer, intChoose As Integer, intNot As Integer, intAccountIn As Integer
    Dim blnOneIn As Boolean
    Dim intRow As Integer '行号
    Dim ChooseRow As Integer
    Dim intErr As Integer   '未完成
    Dim intOk As Integer    '已完成

    On Error GoTo TheErr
    
    If gclsBase.PeriodClosed(gclsBase.BaseDate) = -1 Then
        ShowMsg Me.hwnd, "本期已经结帐,不能执行转帐!", vbInformation + vbOKOnly, App.title
        Exit Sub
    End If
    
    ReDim arrlngAccountID(0)
    ReDim arrintDirection(0)
    ReDim arrdblSumAmount(0)
    ReDim arrdblSumCurrency(0)
    ReDim arrdblSumQuantity(0)
    
    arrlngAccountID(0) = 0
    arrintDirection(0) = 0
    arrdblSumAmount(0) = 0
    arrdblSumCurrency(0) = 0
    arrdblSumQuantity(0) = 0
    
    blnFound = False
    With grdList
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 1) = "√" Then
                blnFound = True
                Exit For
            End If
        Next i
    End With
    If blnFound = False Then Exit Sub
                    
          
    '第 一 步：全部浏览要生成转帐凭证的转帐模板，依据用户的选择，判断是否继续执行下去
    With grdList
        ReDim arrGenCancel(.Rows - 1)
        ReDim arrDelVoucher(.Rows - 1)
        For i = 0 To UBound(arrGenCancel)
            arrGenCancel(i) = 0
            arrDelVoucher(i) = 0
        Next i
        blnFound = False
        intChoose = 0
        intNot = 0
        Set colVoucherNo = New Collection
        Set colDelVoucherNo = New Collection
        For i = 1 To .Rows - 1
            If .TextMatrix(i, 1) = "√" Then
                intChoose = intChoose + 1
                blnFound = True
                lngTransVoucherID = CLng(.TextMatrix(i, 0))
                
                strSql = "SELECT TransVoucher.* From TransVoucher WHERE TransVoucher.lngTransVoucherID=" & lngTransVoucherID
                Set recTemp = gclsBase.BaseDB.OpenResultset(strSql, rdOpenDynamic)
                If recTemp.BOF And recTemp.EOF Then Exit Sub
                
                strTransVoucherName = recTemp!strTransVoucherName
                
                Select Case recTemp!strFrequency
                Case "0"
                    strFrequency = ""
                Case "1"
                    strFrequency = "期"
                Case "2"
                    strFrequency = "年"
                End Select
                Set recTemp = Nothing
                
                intYear = gclsBase.AccountYear
                bytPeriod = gclsBase.Period
                
                '获得本条转帐记录最近生成的凭证
                Select Case strFrequency
                Case ""
                   strSql = "SELECT Voucher.* FROM Voucher,TransVoucher Where Voucher.lngVoucherID = TransVoucher.lngVoucherID And TransVoucher.lngTransVoucherID=" & lngTransVoucherID & " ORDER BY Voucher.lngVoucherID DESC"
                Case "期"
                   strSql = "SELECT Voucher.* FROM Voucher,TransVoucher Where Voucher.lngVoucherSourceID=16 And Voucher.lngSourceVoucherID=" & lngTransVoucherID & " And TransVoucher.lngTransVoucherID=" & lngTransVoucherID & " And Voucher.intyear=" & intYear & " And Voucher.bytPeriod=" & bytPeriod & " ORDER BY Voucher.lngVoucherID DESC"
                Case "年"