frmin.frm

针对农资系统的管理模式而开发的业务部门与财务部门的转账模式和过程

        Else
            ShortQuantityCol = -1
            ShortMoneyCol = -1
            WearQuantityCol = -1
            WearMoneyCol = -1
            WearWhysCol = -1
        End If
        
        For j = i + 1 To i + 5  'FYear, FMonth, FType, FNo, FIndex
            .Columns(j).Visible = False
            .Columns(j).AllowSizing = False
            .Columns(j).Locked = True
            SetColumnWidth sGrdWidth, .Columns(j), 0
        Next
        YearCol = i + 1
        MonthCol = i + 2
        TypeCol = i + 3
        NoCol = i + 4
        IndexCol = i + 5
    End With
End Sub

Private Sub adoPrimaryRs_MoveComplete(ByVal adReason As ADODB.EventReasonEnum, ByVal pError As ADODB.Error, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    Dim sNo As String
    
    With adoPrimaryRs
        If .EOF Or .BOF Or IsNull(![FNo]) Then
            sNo = ""
            maskDate.Text = "____年__月__日"
            lblStatus.Caption = ""
        Else
            sNo = ![FNo]
            maskDate.Text = Format(![FDate], "YYYY年MM月DD日")
            lblStatus.Caption = "序号: " & CStr(adoPrimaryRs.AbsolutePosition)
        End If
    End With
    
    RefreshDataGrid m_gnYear, m_gbyMonth, m_byType, sNo
End Sub

Private Sub adoPrimaryRs_Error(ByVal ErrorNumber As Long, Description As String, ByVal sCode As Long, ByVal Source As String, ByVal HelpFile As String, ByVal HelpContext As Long, fCancelDisplay As Boolean)
'    MsgBox "Data error event hit err:" & Description
    fCancelDisplay = True
End Sub

Private Sub adoPrimaryRs_WillChangeRecord(ByVal adReason As ADODB.EventReasonEnum, ByVal cRecords As Long, adStatus As ADODB.EventStatusEnum, ByVal pRecordset As ADODB.Recordset)
    '验证代码置于此处
    '下列动作发生时该事件被调用
    Dim bCancel As Boolean
    
    Select Case adReason
    Case adRsnAddNew
    Case adRsnClose
    Case adRsnDelete
    Case adRsnFirstChange
    Case adRsnMove
    Case adRsnRequery
    Case adRsnResynch
    Case adRsnUndoAddNew
    Case adRsnUndoDelete
    Case adRsnUndoUpdate
    Case adRsnUpdate
    End Select
    
    If bCancel Then adStatus = adStatusCancel
End Sub



Private Sub DacEntryType_Validate(Cancel As Boolean)
If Not DacEntryType.MatchedWithList Then
    DacEntryType.BoundText = m_EntryTypeRs!FEntrytypeCode
End If
End Sub


Private Sub Form_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        SendKeys "{Tab}"
    End If
End Sub

Private Sub Form_Load()
    SetForm Me, 9
    InitScreenObject
    
    Dim sSqlStr As String
    Set adoPrimaryRs = New ADODB.Recordset
    With adoPrimaryRs
        sSqlStr = "Select FYear, FMonth, FType, FNo, FDate, FHouseCode, FStoreMan, FVerified, FKeeper, FAuditer, FMaker, FStockUpID,FEntryType,FentryCode " & _
            " From WaresIn Where FYear = " & m_gnYear & " And FMonth = " & m_gbyMonth & " And FType = " & m_byType & " Order by FNo"
        .Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
        If Not (.EOF And .BOF) Then .MoveLast
    End With
    
    BoundingScreenObject
    SetButtons (True)
    m_bIsSelectWares = False
End Sub

Private Sub Form_Resize()
    On Error Resume Next
    '当窗体调整时会调整网格
    lblTitle(0).Left = (Me.ScaleWidth - lblTitle(0).Width) / 2
    lblTitle(1).Left = lblTitle(0).Left + 30
    
    With grdDataGrid
        .Left = 50
        .Width = Me.ScaleWidth - .Left * 2
        .Height = Me.ScaleHeight - .Top - picButtons.Height - picStatBox.Height
    End With
    
    txtFindNo.Left = Me.ScaleWidth - txtFindNo.Width - 50
    lblFindNo.Left = txtFindNo.Left - lblFindNo.Width - 50
    
    cmdLast.Left = lblFindNo.Left - 340 - 300
    cmdNext.Left = cmdLast.Left - 340
    
    lblStatus.Width = cmdNext.Left - lblStatus.Left - 20
End Sub

Private Sub Form_Unload(Cancel As Integer)
    Screen.MousePointer = vbDefault
End Sub

'///////////////////////////////////////////////////
'//
Private Sub cmdAdd_Click()
    With adoPrimaryRs
        .AddNew
        cmdUpdate.Left = cmdAdd.Left
        lblStatus.Caption = "添加单据"
        SetButtons (False)
        
        ![FYear] = m_gnYear
        ![FMonth] = m_gbyMonth
        ![FType] = m_byType
        ![FNo] = GetNewInvoiceNo("Select Max(FNo) From WaresIn Where FType = " & m_byType, 0)
        ![FDate] = Format(m_gLoginDate, "YYYY年MM月DD日")
        ![FMaker] = m_gsOperator
        .Update
        
        RefreshDataGrid ![FYear], ![FMonth], ![FType], ![FNo]
        maskDate.Text = Format(![FDate], "YYYY年MM月DD日")
        DACHouse.SetFocus
    End With
End Sub

Private Sub cmdDelete_Click()
    Dim nRet As Integer
    
    With adoPrimaryRs
        If .EOF Or .BOF Then
            Exit Sub
        End If
        
        nRet = MsgBox("您真的要删除当前单据吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
        If nRet = vbYes Then
            '先删除单据明细
            m_gDBCnn.Execute "Delete * From InDetail Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FType = " & ![FType] & " And FNo = '" & ![FNo] & "'"
            '再删除单据头
            .Delete
            .MoveNext
            If .EOF And .RecordCount > 0 Then .MoveLast
        End If
    End With
    
    SetButtons (True)
End Sub

Private Sub cmdEdit_Click()
    If adoPrimaryRs.EOF Or adoPrimaryRs.BOF Then Exit Sub
    
    cmdUpdate.Left = cmdEdit.Left
    lblStatus.Caption = "修改单据"
    SetButtons (False)
    DACHouse.SetFocus
End Sub

Private Function UpdateInvoice() As Boolean
    On Error GoTo UpdateErr
    
    With adoPrimaryRs
        If Not CheckDataValidity() Then
            UpdateInvoice = False
            Exit Function
        End If
        
        ![FDate] = maskDate.Text
        .Update
    End With
    
    UpdateInvoice = True
    Exit Function
    
UpdateErr:
    UpdateInvoice = False
    MsgBox "数据输入有误, 请修改!", vbOKOnly + vbExclamation, "提示："
End Function

Private Sub cmdUpdate_Click()
    If UpdateInvoice() Then
        lblStatus.Caption = "序号: " & CStr(adoPrimaryRs.AbsolutePosition)
        SetButtons (True)
    End If
End Sub

Private Function CheckDetailData() As Boolean
    CheckDetailData = False
    Dim TempRs As ADODB.Recordset
    Dim nRet As Integer
    
    If DACHouse.BoundText = "" Then
        MsgBox "没有选择库房, 不能审核!", vbOKOnly + vbExclamation, "提示:"
        Exit Function
    End If
    
    Set TempRs = adoSecondaryRs.Clone
    With TempRs
        If .RecordCount = 0 Then
            If m_byType = SURROGATE_INVOICE Or m_byType = WASTAGE_INVOICE Then  '代管入库、盘点单
                MsgBox "没有录入单据明细数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
                Exit Function
            ElseIf m_byType = IN_INVOICE Or m_byType = BACK_INVOICE Then        '验收入库、商品退还
                CheckDetailData = True
                Exit Function
            End If
        End If
        
        '检查是否存在零数量
        If m_byType = IN_INVOICE Or m_byType = SURROGATE_INVOICE Or m_byType = BACK_INVOICE Then
            .Filter = "FQuantity = 0"
            If Not .EOF Then
                MsgBox "单据明细存在实收数量为零的数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
                Exit Function
            End If
        ElseIf m_byType = WASTAGE_INVOICE Then   '盘点单
            .Filter = "FShortQuantity = 0 And FWearQuantity = 0"
            If Not .EOF Then
                MsgBox "长短量和溢损量同时为零, 不能审核!", vbOKOnly + vbExclamation, "提示:"
                Exit Function
            End If
        End If
        
        '检查发票数量是否等于实收数量、长短数量、溢损数量之和
        If m_byType = IN_INVOICE Or m_byType = BACK_INVOICE Then
            .Filter = adFilterNone
            Do While Not .EOF
                If Abs(![SUQuantity] - ![FQuantity] - (![FShortQuantity] + ![FwearQuantity]) * -1) >= 0.01 Then
                    MsgBox "单据明细存在发票数量不等于实收数量、长短数量、" & Chr(13) & "溢损数量之和的数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
                    Exit Function
                End If
                .MoveNext
            Loop
        End If
        
        '检查数量与金额是否相符
        If m_byType = IN_INVOICE Or m_byType = WASTAGE_INVOICE Or m_byType = BACK_INVOICE Then
            If m_byType = IN_INVOICE Or m_byType = BACK_INVOICE Then
                .Filter = "(FQuantity = 0 And FMoney <> 0) Or (FQuantity <> 0 And FMoney = 0)"
            Else
                '.Filter = "(FShortQuantity = 0 And FShortMoney <> 0) Or (FShortQuantity <> 0 And FShortMoney = 0) or (FWearQuantity = 0 And FWearMoney <> 0) Or (FWearQuantity <> 0 And FWearMoney = 0)"
            End If
            If Not .EOF Then
                MsgBox "单据明细存在数量与金额不符的商品, 不能审核!", vbOKOnly + vbExclamation, "提示:"
                Exit Function
            End If
        End If
    End With
    Set TempRs = Nothing
    CheckDetailData = True
End Function

Private Sub cmdAuditer_Click()
    With adoPrimaryRs
        If IsNull(![FAuditer]) Or ![FAuditer] = "" Then     '未审核
            If Not CheckDetailData() Then Exit Sub
            ![FAuditer] = m_gsOperator
        Else
            ![FAuditer] = ""
        End If
        .Update
    End With
    SetButtons (True)
End Sub

Private Sub cmdKeeper_Click()   '记帐
    Dim nRet As Integer, sPrompt As String
    
    With adoPrimaryRs
        If Not (IsNull(![FKeeper]) Or ![FKeeper] = "") Then  '已记帐
            Exit Sub
        End If
        nRet = MsgBox("本单据记帐后不能更改, 您要继续吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
        If nRet = vbNo Then Exit Sub
    End With
    With adoSecondaryRs
        m_gDBCnn.BeginTrans
        'If Not KeepRecord(![Fyear], ![Fmonth], ![FType], ![Fno], ![FhouseCode], sPrompt) Then
         '   GoTo RollBack_ERROR
        Do While Not .EOF
            If Not KeepRecord(DACHouse.BoundText, !FWaresCode, "升耗", adoPrimaryRs![FNo], !FwearQuantity, !FPrice, !FWearMoney, DacEntryType.BoundText, txtEntryNo.Text, 4) Then
              GoTo RollBack_ERROR
            End If
            .MoveNext
        Loop
        
        adoPrimaryRs![FKeeper] = m_gsOperator
        adoPrimaryRs.Update
        m_gDBCnn.CommitTrans
    End With
    SetButtons (True)
    Exit Sub
    
RollBack_ERROR:
    m_gDBCnn.RollbackTrans
    If sPrompt <> "" Then
        MsgBox sPrompt, vbOKOnly + vbExclamation, "提示:"
    Else
        MsgBox "数据共享冲突, 记帐不成功!", vbOKOnly + vbExclamation, "提示:"
    End If
    adoPrimaryRs![FKeeper] = ""
    adoPrimaryRs.Update
End Sub

Private Sub cmdClose_Click()
    Unload Me
End Sub

'////////////////////////////////////////////////
'//
Private Sub cmdFirst_Click()
    With adoPrimaryRs
        If .EOF And .BOF Then Exit Sub
        If .AbsolutePosition = 1 Then Exit Sub  '已是首记录
        .MoveFirst
    End With
    SetButtons (True)
End Sub

Private Sub cmdLast_Click()
    With adoPrimaryRs
        If .EOF And .BOF Then Exit Sub
        If .AbsolutePosition = .RecordCount Then Exit Sub    '已是尾记录
        .MoveLast
    End With
    SetButtons (True)
End Sub

Private Sub cmdNext_Click()
    With adoPrimaryRs
        If .EOF And .BOF Then Exit Sub
        If .AbsolutePosition = .RecordCount Then Exit Sub    '已是尾记录
        .MoveNext
    End With
    SetButtons (True)
End Sub

Private Sub cmdPrevious_Click()
    With adoPrimaryRs
        If .EOF And .BOF Then Exit Sub
        If .AbsolutePosition = 1 Then Exit Sub   '已是首记录
        .MovePrevious
    End With
    SetButtons (True)
End Sub

'///////////////////////////////////////////////////
'//
Private Sub SetButtons(bVal As Boolean)
    Dim bAuditer As Boolean, bKeeper As Boolean, bEmpty As Boolean
    With adoPrimaryRs
        If .EOF Or .BOF Then
            bAuditer = True
            bKeeper = True
            bEmpty = True
        Else
            bAuditer = IIf(IsNull(![FAuditer]) Or ![FAuditer] = "", False, True) '未审核/审核
            bKeeper = IIf(IsNull(![FKeeper]) Or ![FKeeper] = "", False, True)    '未记帐/记帐
            bEmpty = False
        End If
    End With
    
    DACHouse.Enabled = Not bVal
    maskDate.Enabled = Not bVal
    txtNo.Enabled = False
    DacEntryType.Enabled = Not bVal