frmstockup.frm

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

                 'Left Join Supplier On StockUp.FSupplierCode = Supplier.FSupplierCode
        sSqlStr = "Select FYear, FMonth, FType, FNo, FDate, FDepartCode,FentryType,FEntryCode, FCustomerName, FCustomerInfo,  FChequeNo, FHandler, FKeeper, FAuditer, FMaker, FStockUpId " & _
            " From StockUp " & _
            " Where FYear = " & m_gnYear & " And FMonth = " & m_gbyMonth & " And FType = " & m_byType & " Order by FStockUpID"
        .Open sSqlStr, m_gDBCnn, adOpenDynamic, adLockOptimistic, adCmdUnknown
        .Properties("Unique Table") = "StockUp"
        .Properties("Resync Command") = "Select * FROM (" & sSqlStr & ") WHERE FYear = ? And FMonth = ? And FType = ? And FNo = ?"
        .Properties("Update Resync") = adResyncAll Or adResyncUpdates Or adResyncInserts Or adResyncConflicts
        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
        maskDate.Text = Format(m_gLoginDate, "YYYY年MM月DD日")
        txtMaker.Text = m_gsOperator
        txtNo.Text = GetNextNo()
        DACDepart.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 StockUpDetail 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)
    DACDepart.SetFocus
End Sub

Private Function UpdateInvoice() As Boolean
    On Error GoTo UpdateErr
    
    With adoPrimaryRs
        If Not CheckDataValidity() Then
            UpdateInvoice = False
            Exit Function
        End If
        
        m_gDBCnn.BeginTrans
        If txtNo.Text <> ![FNo] Or IsNull(![FNo]) Then     '单据号改变, 连锁更新单据明细
            m_gDBCnn.Execute "Update StockUpDetail Set FNo = '" & txtNo.Text & "' Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FType = " & ![FType] & " And FNo = '" & ![FNo] & "'"
            RefreshDataGrid ![FYear], ![FMonth], ![FType], txtNo.Text
        End If
        ![FNo] = txtNo.Text
        ![FDate] = maskDate.Text
        
        .Update
        m_gDBCnn.CommitTrans
    End With
    
    UpdateInvoice = True
    Exit Function
    
UpdateErr:
    m_gDBCnn.RollbackTrans
    MsgBox "数据输入有误, 请修改!", vbOKOnly + vbExclamation, "提示："
    UpdateInvoice = False
    DACDepart.SetFocus
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
    
    Set TempRs = adoSecondaryRs.Clone
    With TempRs
        If .RecordCount = 0 Then
            MsgBox "没有录入单据明细数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
            Exit Function
        End If
        
        '检查是否存在零进货量
        .Filter = "FWaresCode < '" & CHARGE_CODE & "' And FQuantity = 0"
        If Not .EOF Then
            MsgBox "单据明细存在采购数量为零的数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
            Exit Function
        End If
        
        '检查数量与金额是否相符
'        "Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'"
        .Filter = "(FWaresCode < '" & CHARGE_CODE & "' And FQuantity = 0 And FMoney <> 0) Or (FWaresCode < '" & CHARGE_CODE & "' And FQuantity <> 0 And FMoney = 0)"
        If Not .EOF Then
            MsgBox "单据明细存在数量与金额不符的数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
            Exit Function
        End If
        .Filter = ""
        If Not .EOF Then
            Dim sPrompt As String
            Dim result As Integer
            result = 0
            sPrompt = "下列商品的数量*单价<>金额" & vbCr
            Do While Not .EOF
                If (!FQuantity * !FPrice - !Fmoney) <> 0 Then
                    sPrompt = sPrompt & !FWaresCode & vbCr
                    result = result + 1
                End If
                .MoveNext
            Loop
            sPrompt = sPrompt & "如果您想保留，请按确定!"
            If result <> 0 Then
                result = MsgBox(sPrompt, vbYesNoCancel, "提示")
                If result <> vbOK Then Exit Function
            End If
            
        End If
        '检查费用金额是否为零
        .Filter = "FWaresCode Like '" & CHARGE_CODE & "%' And FMoney = 0"
        If Not .EOF Then
            MsgBox "单据明细存在经营费用为零的数据, 不能审核!", vbOKOnly + vbExclamation, "提示:"
            Exit Function
        End If
        
        .Filter = adFilterNone
        If .RecordCount = GetChargeRows() Then
            nRet = MsgBox("单据明细仅有费用数据, 您确信是正确的吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
            If nRet = vbNo Then Exit Function
        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 Function GetChargeRows() As Integer
    Dim TempRs As ADODB.Recordset, nCount As Integer
    Set TempRs = adoSecondaryRs.Clone
    With TempRs
        nCount = 0
        Do While 1
            .Find "FWaresCode Like '" & CHARGE_CODE & "%'"
            If Not .EOF Then
                nCount = nCount + 1
                .MoveNext
            Else
                Exit Do
            End If
        Loop
    End With
    Set TempRs = Nothing
    GetChargeRows = nCount
End Function

Private Sub cmdKeeper_Click()   '记帐
    Dim sHouseCode As String, nAttrib As Integer
    Dim sFields As String, sValues As String
    Dim sNewNo As String, nAffected As Integer
    Dim nRet As Integer, sPrompt As String
    Dim nChargeRows As Integer, byInType As Byte
    
    With adoPrimaryRs
        If Not (IsNull(![FKeeper]) Or ![FKeeper] = "") Then  '已记帐
            Exit Sub
        End If
        nRet = MsgBox("本单据记帐后不能更改, 您要继续吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
        If nRet = vbNo Then Exit Sub
        
        '生成入库单
        frmInputHouse.Show vbModal
        sHouseCode = frmInputHouse.m_sHouseId
        nAttrib = frmInputHouse.m_nAttrib
        Unload frmInputHouse
        If sHouseCode = "" Then Exit Sub
        
        'nChargeRows = GetChargeRows()
'        If m_byType = STOCKUP_INVOICE Or m_byType = INFORMAL_INVOICE Then
'            byInType = IN_INVOICE
'        ElseIf m_byType = RETURN_INVOICE Then
'            byInType = BACK_INVOICE
'        End If
'        'sNewNo = GetNewInvoiceNo("Select Max(FNo) From WaresIn Where FType = " & byInType, 0)

        m_gDBCnn.BeginTrans
        Dim result As Boolean
        Dim strUpdateSql As String
        'Dim nAffected As Integer
        With adoSecondaryRs
        Do While Not .EOF
            result = KeepRecord(sHouseCode, !FWaresCode, txtCustomerName.Text, txtNo.Text, !FQuantity, !FPrice, !Fmoney, DacEntryType.BoundText, txtEntryNo.Text, 1)
            If Not result Then GoTo RollBack_ERROR
            strUpdateSql = "Update Balance set FQuantity=FQuantity +" & !FQuantity & " where FWaresCode ='" & !FWaresCode & "' and FHouseCode ='" & sHouseCode & "'"
            m_gDBCnn.Execute strUpdateSql, nAffected
            If nAffected <> 1 Then GoTo RollBack_ERROR
            .MoveNext
        Loop
        End With
'
'        If nAttrib = INNER_HOUSE Then       '内库
'            sFields = "(FYear, FMonth, FType, FNo, FDate, FHouseCode, FMaker, FStockUpID)"
'            sValues = " Values (" & ![FYear] & "," & ![FMonth] & "," & byInType & ",'" & sNewNo & "',#" & Format(m_gLoginDate, "yyyy-mm-dd") & "#,'" & sHouseCode & "','" & m_gsOperator & "'," & ![FStockUpId] & ")"
'        ElseIf nAttrib = OUTER_HOUSE Then   '外库
'            sFields = "(FYear, FMonth, FType, FNo, FDate, FHouseCode, FMaker, FKeeper, FAuditer, FStockUpID)"
'            sValues = " Values (" & ![FYear] & "," & ![FMonth] & "," & byInType & ",'" & sNewNo & "',#" & Format(m_gLoginDate, "yyyy-mm-dd") & "#,'" & sHouseCode & "','" & m_gsOperator & "','" & m_gsOperator & "','" & m_gsOperator & "'," & ![FStockUpId] & ")"
'        End If
'        m_gDBCnn.Execute "Insert Into WaresIn " & sFields & sValues, nAffected
'        If nAffected <> 1 Then GoTo RollBack_ERROR
'
'        If nAttrib = INNER_HOUSE Then
'            sFields = " (FYear, FMonth, FType, FNo, FIndex, FWaresCode, FIdentifyId, FPrice) "
'            sValues = " Select FYear, FMonth, " & byInType & ", '" & sNewNo & "', FIdentifyId, FWaresCode, FIdentifyId, FPrice From StockUpDetail "
'        ElseIf nAttrib = OUTER_HOUSE Then
'            sFields = " (FYear, FMonth, FType, FNo, FIndex, FWaresCode, FIdentifyId, FQuantity, FPrice, FMoney) "
'            sValues = " Select FYear, FMonth, " & byInType & ", '" & sNewNo & "', FIdentifyId, FWaresCode, FIdentifyId, FQuantity, FPrice, FMoney From StockUpDetail "
'        End If
'        sValues = sValues & " Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FType = " & ![FType] & " And FNo = '" & ![FNo] & "' And Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'"
'        m_gDBCnn.Execute "Insert Into InDetail " & sFields & sValues, nAffected
'        If nAffected <> adoSecondaryRs.RecordCount - nChargeRows Then GoTo RollBack_ERROR
'
'        If nAttrib = OUTER_HOUSE Then
'            If Not WaresInRecord(![FYear], ![FMonth], byInType, sNewNo, sHouseCode, sPrompt) Then
'                GoTo RollBack_ERROR
'            End If
'        End If
        
        ![FKeeper] = m_gsOperator
        .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
    
    DACDepart.Enabled = Not bVal
    'DACSupplier.Enabled = Not bVal
    DacEntryType.Enabled = Not bVal
    maskDate.Enabled = Not bVal
    txtNo.Enabled = Not bVal
    txtEntryNo.Enabled = Not bVal
    Me.txtCustomerName.Enabled = Not bVal
    Me.txtCustomerInfo.Enabled = Not bVal
    
    txtHandler.Enabled = Not bVal
    txtKeeper.Enabled = False
    txtAuditer.Enabled = False
    txtMaker.Enabled = False
    txtFindNo.Enabled = bVal And Not bEmpty
    
    grdDataGrid.AllowUpdate = Not bVal
    
    cmdAdd.Enabled = bVal And m_bEdit
    cmdEdit.Enabled = bVal And Not bAuditer And m_bEdit
    cmdUpdate.Visible = Not bVal
    cmdDelete.Enabled = bVal And Not bAuditer And m_bEdit
    cmdPrint.Enabled = bVal And Not bEmpty And bAuditer
    cmdClose.Enabled = bVal
    
    cmdFirst.Enabled = bVal
    cmdLast.Enabled = bVal
    cmdPrevious.Enabled = bVal
    cmdNext.Enabled = bVal
    
    cmdAuditer.Enabled = bVal And Not bKeeper And m_bAuditer
    cmdKeeper.Enabled = bVal And bAuditer And Not bKeeper And m_bKeeper
    
    cmdAuditer.Caption = IIf(Not bKeeper And bAuditer And m_bAuditer, "弃审", "审核")
End Sub

'////////////////////////////////////////////////////
'//
Private Sub grdDataGrid_AfterColUpdate(ByVal ColIndex As Integer)
    With grdDataGrid
        Select Case ColIndex
        Case CodeCol
            If m_sWaresCode <> "" Then