frmwaressell.frm

针对农资系统的商品进销存管理系统软件

Private Function GetTaxRate(sPercentRate As String) As Double
    Dim nPos As Integer
    
    nPos = InStr(1, sPercentRate, "%")
    If nPos > 0 Then
        sPercentRate = Left(sPercentRate, nPos - 1)
    End If
    GetTaxRate = Val(sPercentRate) / 100
End Function

Private Sub grdDataGrid_BeforeColEdit(ByVal ColIndex As Integer, ByVal KeyAscii As Integer, Cancel As Integer)
    If ColIndex = HouseCol Then
        grdDataGrid.Columns(ColIndex).Locked = True
        Cancel = True
        grdDataGrid_ButtonClick (HouseCol)
        grdDataGrid.Columns(ColIndex).Locked = False
    End If
End Sub

Private Sub grdDataGrid_ButtonClick(ByVal ColIndex As Integer)
    If Not grdDataGrid.AllowUpdate Or (ColIndex <> CodeCol And ColIndex <> HouseCol) Or m_bIsSelectWares Then
        Exit Sub
    End If
    Select Case ColIndex
    Case CodeCol
        Dim sOldCode As String
        
        m_sWaresCode = GetSelectWaresCode("Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'", m_bIsSelectWares)
        If m_sWaresCode = "" Then Exit Sub
        
        sOldCode = IIf(IsNull(adoSecondaryRs![FWaresCode]), "", adoSecondaryRs![FWaresCode])
        If m_sWaresCode <> sOldCode Then
            If FieldIsRepeat(adoSecondaryRs.Clone, "FWaresCode = '" & m_sWaresCode & "'") Then
                MsgBox "本单据该商品重复录入!", vbOKOnly + vbExclamation, "提示："
                m_sWaresCode = ""
                Me.SetFocus
            Else
                grdDataGrid_AfterColUpdate (CodeCol)
                SendKeys "{Tab}"
            End If
        End If
    Case HouseCol
         With grdDataGrid
            Dim dLeft As Single, dWidth As Single, dTop As Single, dHeight As Single
            dLeft = .Left + .Columns(ColIndex).Left
            dWidth = .Columns(ColIndex).Width
            dTop = .Top + .RowTop(.Row) + .RowHeight
            dHeight = .RowHeight
            
            DALHouse.Move dLeft, dTop, dWidth
            DALHouse.Visible = True
            DALHouse.SetFocus
        End With
    End Select
End Sub

Private Sub DALHouse_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    DALHouse_KeyPress (13)
End Sub

Private Sub DALHouse_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        With grdDataGrid
'            .Col = HouseCodeCol
'            .Text = DALHouse.BoundText
            .Columns(HouseCodeCol).Text = DALHouse.BoundText
            On Error Resume Next
            adoSecondaryRs.Update
            .SetFocus
        End With
    End If
End Sub

Private Sub DALHouse_LostFocus()
    DALHouse.Visible = False
End Sub

Private Sub grdDataGrid_BeforeColUpdate(ByVal ColIndex As Integer, OldValue As Variant, Cancel As Integer)
    With grdDataGrid
        Select Case ColIndex
        Case CodeCol
            If .Text <> OldValue Then     '代码改变, 检查代码合法性
                If m_bIsSelectWares Then
                    Cancel = True
                    m_sWaresCode = ""
                    Exit Sub
                End If
                
                m_sWaresCode = .Text
                If RsIsEmpty("Select * From WaresList Where FWaresCode = '" & m_sWaresCode & "' And Not FMaster") Then
                    m_sWaresCode = GetSelectWaresCode("Left(FWaresCode, " & m_gSeriesLen(0) & ") <> '" & CHARGE_CODE & "'", m_bIsSelectWares)
                    If m_sWaresCode = "" Then
                        Cancel = True
                        Me.SetFocus
                        Exit Sub
                    End If
                End If
                
                If m_sWaresCode <> OldValue Then
                    If FieldIsRepeat(adoSecondaryRs.Clone, "FWaresCode = '" & m_sWaresCode & "'") Then
                        MsgBox "本单据该商品重复录入!", vbOKOnly + vbExclamation, "提示："
                        m_sWaresCode = ""
                        Cancel = True
                        Me.SetFocus
                        Exit Sub
                    End If
                End If
            End If
            
        Case QuantityCol, PriceCol, MoneyCol, RateCol, TaxCol
            If Not IsNumeric(.Text) Then
                Cancel = True
            ElseIf ColIndex = PriceCol Or ColIndex = RateCol Then
                If Val(.Text) < 0 Then   '单价及税率不能为负数
                    Cancel = True
                End If
            ElseIf ColIndex = MoneyCol Then
                If Val(.Text) < 0 And Val(.Columns(QuantityCol).Text) > 0 Or Val(.Text) > 0 And Val(.Columns(QuantityCol).Text) < 0 Then
                    Cancel = True
                End If
            ElseIf ColIndex = TaxCol Then
                If Val(.Text) < 0 And Val(.Columns(MoneyCol).Text) > 0 Or Val(.Text) > 0 And Val(.Columns(MoneyCol).Text) < 0 Then
                    Cancel = True
                End If
            End If
            
        End Select
    End With
End Sub

Private Sub grdDataGrid_BeforeDelete(Cancel As Integer)
    Dim nRet As Integer
    nRet = MsgBox("您真的要删除当前商品吗？", vbQuestion + vbYesNo + vbDefaultButton2, "提示：")
    If nRet = vbNo Then Cancel = True
End Sub

Private Sub grdDataGrid_BeforeUpdate(Cancel As Integer)
    If adoSecondaryRs.EditMode = adEditDelete Then Exit Sub
    With grdDataGrid
        If .Columns(CodeCol).Text = "" Then
            .DataChanged = False
            Cancel = True
        End If
    End With
End Sub

Private Sub grdDataGrid_Error(ByVal DataError As Integer, Response As Integer)
    Response = 0
End Sub

Private Sub grdDataGrid_GotFocus()
    If grdDataGrid.AllowUpdate Then
        UpdateInvoice
    ElseIf cmdEdit.Enabled Then
        cmdEdit.SetFocus
    ElseIf cmdAdd.Enabled Then
        cmdAdd.SetFocus
    ElseIf cmdPrint.Enabled Then
        cmdPrint.SetFocus
    ElseIf cmdClose.Enabled Then
        cmdClose.SetFocus
    Else
        Me.SetFocus
    End If
End Sub

Private Sub grdDataGrid_LostFocus()
    If m_bIsSelectWares Then Exit Sub
    If Me.ActiveControl Is DALHouse Then Exit Sub
    On Error GoTo Error_Handler
    
    If Not grdDataGrid.AddNewMode = dbgAddNewCurrent Then adoSecondaryRs.Update
    If Not grdDataGrid.AddNewMode = dbgNoAddNew Then
        adoSecondaryRs.MoveLast
    End If

Error_Handler:
End Sub

Private Sub grdDataGrid_RowResize(Cancel As Integer)
    If grdDataGrid.RowHeight < 200 Then
        grdDataGrid.RowHeight = 200
    ElseIf grdDataGrid.RowHeight > grdDataGrid.Height / 2 Then
        grdDataGrid.RowHeight = grdDataGrid.Height / 2
    End If
    SavePrivateSetting Me.Caption, "GrdHeight", grdDataGrid.RowHeight
End Sub

Private Sub grdDataGrid_ColResize(ByVal ColIndex As Integer, Cancel As Integer)
    If grdDataGrid.VisibleCols = 0 Then
        Cancel = True
    Else
        SaveGridColWidth Me.Caption, grdDataGrid
    End If
End Sub

'//////////////////////////////////////////////////
'//
Private Sub DACDepart_Validate(Cancel As Boolean)
    If Not dacDepart.MatchedWithList Then
'        MsgBox "请重新选择销售部门!", vbOKOnly + vbExclamation, "提示："
'        Cancel = True
        
        dacDepart.BoundText = m_DepartRs!FDepartCode
        
        dacDepart.SetFocus
    End If
End Sub

Private Function GetCustomerAddress(sCode As String) As String
    Dim TempRs As ADODB.Recordset
    Set TempRs = New ADODB.Recordset
    With TempRs
        .Open "Select * From Customer Where FCustomerCode = '" & sCode & "'", m_gDBCnn
        If .EOF And .BOF Then
            GetCustomerAddress = ""
        Else
            GetCustomerAddress = IIf(IsNull(![FAddress]), "", ![FAddress]) & "," & IIf(IsNull(![FTel]), "", ![FTel])
        End If
    End With
End Function

Private Sub DACCustomer_Validate(Cancel As Boolean)
    If Not DACCustomer.MatchedWithList Then
'        MsgBox "请重新选择购货单位!", vbOKOnly + vbExclamation, "提示："
         DACCustomer.BoundText = m_CustomerRs!FCustomerCode
        Cancel = True
       
        DACCustomer.SetFocus
    Else
        lblAddressTel.Caption = GetCustomerAddress(DACCustomer.BoundText)
    End If
End Sub

Private Sub MaskDate_Validate(Cancel As Boolean)
    If Not IsDate(maskDate.Text) Then
        MsgBox "日期输入有误!", vbOKOnly + vbExclamation, "提示："
        Cancel = True
        maskDate.SetFocus
    End If
End Sub

Private Sub txtNo_Validate(Cancel As Boolean)
    If Trim(txtNo.Text) = "" Then
        MsgBox "请输入单据号!", vbOKOnly + vbExclamation, "提示："
        Cancel = True
    Else
        txtNo.Text = Trim(txtNo.Text)
    End If
End Sub

'////////////////////////////////////////////////
'//
Private Sub txtFindNo_LostFocus()
    txtFindNo.Text = ""
End Sub

Private Sub txtFindNo_KeyPress(KeyAscii As Integer)
    If KeyAscii <> 13 Then
        Exit Sub
    ElseIf Trim(txtFindNo.Text) = "" Then
        Exit Sub
    End If
    
    FindRecord adoPrimaryRs, Trim(txtFindNo.Text)
End Sub

'////////////////////////////////////////////////
'//
Private Function CheckDataValidity() As Boolean
    Dim sPrompt As String
    sPrompt = ""
    If dacDepart.BoundText = "" Then
        sPrompt = "请选择销售部门!" & Chr(13)
    End If
    
    If DACCustomer.BoundText = "" Then
        sPrompt = sPrompt & "请选择购货单位!" & Chr(13)
    End If
    
    If Not IsDate(maskDate.Text) Then
        sPrompt = sPrompt & "日期输入有误!" & Chr(13)
    End If
    
    With adoPrimaryRs
        If txtNo.Text = "" Then
            sPrompt = sPrompt & "请输入单据号!" & Chr(13)
        ElseIf txtNo.Text <> ![FNo] Or IsNull(![FNo]) Then         '检查单据号是否重复
            If Not RsIsEmpty("Select * From Sell Where FYear = " & ![FYear] & " And FMonth = " & ![FMonth] & " And FType = " & ![FType] & " And FNo = '" & txtNo.Text & "'") Then
                sPrompt = sPrompt & "单据号重复, 请重新输入!" & Chr(13)
            End If
        End If
    End With
  
    If sPrompt = "" Then
        CheckDataValidity = True
    Else
        MsgBox sPrompt, vbInformation + vbOKOnly, "提示："
        dacDepart.SetFocus
        CheckDataValidity = False
    End If
End Function

Function AddWaresOut(nAttrib As Integer, nYear As Integer, nMonth As Byte, sNo As String, sHouseCode As String, sSellNo As String) As Boolean
    Dim sFields As String, sValues As String, nAffected As Integer
    If nAttrib = INNER_HOUSE Then       '内库 ???
            sFields = "(FYear, FMonth, FType, FNo, FDate, FHouseCode,FSellNO, FMaker)"
            sValues = " Values (" & nYear & "," & nMonth & "," & IIf(m_byType = REDSELL_INVOICE, OUT_RED, OUT_SELL) & ",'" & sNo & "',#" & Format(m_gLoginDate, "yyyy-mm-dd") & "#,'" & sHouseCode & "','" & sSellNo & "','" & m_gsOperator & "')"
    ElseIf nAttrib = OUTER_HOUSE Then   '外库
            sFields = "(FYear, FMonth, FType, FNo, FDate, FHouseCode,FSellNO, FMaker, FKeeper, FAuditer)"
            sValues = " Values (" & nYear & "," & nMonth & "," & IIf(m_byType = REDSELL_INVOICE, OUT_RED, OUT_SELL) & ",'" & sNo & "',#" & Format(m_gLoginDate, "yyyy-mm-dd") & "#,'" & sHouseCode & "','" & sSellNo & "','" & m_gsOperator & "','" & m_gsOperator & "','" & m_gsOperator & "')"
    End If
    '填写出库单
    m_gDBCnn.Execute "Insert Into Waresout " & sFields & sValues, nAffected
    If nAffected <> 1 Then
        AddWaresOut = False
    Else
        AddWaresOut = True
    End If
End Function

'填写出库单明细
Function AddWaresOutDetail(nAttrib As Integer, nYear As Integer, nMonth As Byte, sNo As String, sWarescode As String, dblQuantity As Double, dblPrice As Double, curMoney As Currency, nPriceMode As Integer, sHouseCode As String) As Boolean
    Dim sFields As String, sValues As String, nAffected As Integer
    
    sFields = " (FYear, FMonth, FType, FNo, FWaresCode,  FQuantity) "
    sValues = " Values (" & nYear & "," & nMonth & "," & IIf(m_byType = REDSELL_INVOICE, OUT_RED, OUT_SELL) & ",'" & sNo & "','" & sWarescode & "'," & dblQuantity & ")"
    
    On Error GoTo DataUpdate_Error
    m_gDBCnn.Execute "Insert Into OutDetail " & sFields & sValues, nAffected
    If nAffected <> 1 Then GoTo DataUpdate_Error
    '更新balance表中的参考数量
    Dim strSQL As String
    
        strSQL = "update balance set FReferencedQuantity =FReferencedQuantity + " & dblQuantity & ", FAuditQuantity = FAuditQuantity -" & dblQuantity & _
        " where FHouseCode ='" & sHouseCode & "' and FWaresCode = '" & sWarescode & "'"
        m_gDBCnn.Execute strSQL, nAffected
        If nAffected <> 1 Then GoTo DataUpdate_Error
    
    '若为外库添加出