frmstockup.frm

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

                .Columns(YearCol).Text = adoPrimaryRs![FYear]
                .Columns(MonthCol).Text = adoPrimaryRs![FMonth]
                .Columns(TypeCol).Text = adoPrimaryRs![FType]
                .Columns(NoCol).Text = adoPrimaryRs![FNo]
                .Text = m_sWaresCode
                adoSecondaryRs.Update
                .Col = MeasCol
            End If
            
        Case QuantityCol, PriceCol
            .Columns(MoneyCol).Text = Val(.Columns(QuantityCol).Text) * Val(.Columns(PriceCol).Text)
            .Columns(TaxCol).Text = Val(.Columns(MoneyCol).Text) * GetTaxRate(.Columns(RateCol).Text)
            If ColIndex = PriceCol Then .Col = MoneyCol
            
        Case MoneyCol
            If Val(.Columns(QuantityCol).Text) = 0 Then
                .Columns(PriceCol).Text = 0
            Else
                .Columns(PriceCol).Text = Val(.Columns(MoneyCol).Text) / Val(.Columns(QuantityCol).Text)
            End If
            .Columns(TaxCol).Text = Val(.Columns(MoneyCol).Text) * GetTaxRate(.Columns(RateCol).Text)
            
        Case RateCol
            .Columns(TaxCol).Text = Val(.Columns(MoneyCol).Text) * GetTaxRate(.Columns(RateCol).Text)
            .Col = TaxCol
            
        Case TaxCol
            If Val(.Columns(MoneyCol).Text) = 0 Then
                .Columns(RateCol).Text = 0
            Else
                .Columns(RateCol).Text = Val(.Columns(TaxCol).Text) / Val(.Columns(MoneyCol).Text)
            End If
        End Select
    End With
End Sub

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_ButtonClick(ByVal ColIndex As Integer)
    If Not grdDataGrid.AllowUpdate Or ColIndex <> CodeCol Or m_bIsSelectWares Then
        Exit Sub
    End If
    Dim sOldCode As String
    
    m_sWaresCode = GetSelectWaresCode("", 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
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("", 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 PriceCol, RateCol
            If Not IsNumeric(.Text) Then
                Cancel = True
            ElseIf Val(.Text) < 0 Then   '单价及税率不能为负数
                Cancel = True
            End If
        Case QuantityCol, MoneyCol, TaxCol    'lz 1999.11.16  去掉负数检查
            If Not IsNumeric(.Text) Then
                Cancel = True
'            ElseIf (m_byType = STOCKUP_INVOICE Or m_byType = INFORMAL_INVOICE) And Val(.Text) < 0 Then
'                Cancel = True
'            ElseIf m_byType = RETURN_INVOICE And Val(.Text) > 0 Then
'                Cancel = True
            End If
'        Case QuantityCol, MoneyCol, TaxCol    'lz 1999.11.16
'            If Not IsNumeric(.Text) Then
'                Cancel = True
'            ElseIf (m_byType = STOCKUP_INVOICE Or m_byType = INFORMAL_INVOICE) And Val(.Text) < 0 Then
'                Cancel = True
'            ElseIf m_byType = RETURN_INVOICE And Val(.Text) > 0 Then
'                Cancel = True
'            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
    On Error GoTo Error_Handler
    
    If Not grdDataGrid.AddNewMode = dbgAddNewCurrent Then
        adoSecondaryRs.Update
    End If
    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 GetSupplierAddress(sCode As String) As String
    Dim TempRs As ADODB.Recordset
    Set TempRs = New ADODB.Recordset
    With TempRs
        .Open "Select * From Supplier Where FSupplierCode = '" & sCode & "'", m_gDBCnn
        If .EOF And .BOF Then
            GetSupplierAddress = ""
        Else
            GetSupplierAddress = IIf(IsNull(![FAddress]), "", ![FAddress]) & "," & IIf(IsNull(![FTel]), "", ![FTel])
        End If
    End With
End Function

'Private Sub DACSupplier_Validate(Cancel As Boolean)
'    If Not DACSupplier.MatchedWithList Then
''        MsgBox "请重新选择供货单位!", vbOKOnly + vbExclamation, "提示："
'        DACSupplier.BoundText = m_SupplierRs!FSupplierCode
'        'Cancel = True
'        DACSupplier.SetFocus
'    Else
'        lblAddressTel.Caption = GetSupplierAddress(DACSupplier.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 DACSupplier.BoundText = "" Then
'        sPrompt = sPrompt & "请选择供货单位!" & Chr(13)
'    End If
'
    If Not IsDate(maskDate.Text) Then
        sPrompt = sPrompt & "日期输入有误!" & Chr(13)
    End If
    If m_byType = STOCKUP_INVOICE Then
        If Me.txtEntryNo.Text = "" Or (Not IsNumeric(txtEntryNo.Text)) Then
            sPrompt = sPrompt & "没有输入有效的凭证号!" & Chr(13)
        End If
        If Me.DacEntryType.BoundText = "" Then
            sPrompt = sPrompt & "没有输入有效的凭证类!" & Chr(13)
        End If
    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 StockUp 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

'////////////////////////////////////////////////
'//
Private Sub cmdPrint_Click()
    Let frmPrint.Initial(Me.Caption, Me.GrdColumns) = Me
    frmPrint.Show vbModal
End Sub

Property Get GrdColumns() As Object
    Set GrdColumns = grdDataGrid.Columns
End Property

Property Get DataType() As String
    DataType = "Grid"
End Property

Property Get PrintCaption() As String
    PrintCaption = lblTitle(0).Caption
End Property

Public Sub PrintMe(ByRef PrintObj As Object, Optional sRangeInfo As String)
    If sRangeInfo = "" Then
        PrintTable grdDataGrid, adoSecondaryRs, Me, True, PrintObj, False
    Else
        Dim nFromPage As Integer, nEndPage As Integer
        Do While Len(sRangeInfo) > 0
            GetFromToEndPageNo sRangeInfo, nFromPage, nEndPage  '三个参数均传址调用
            PrintTable grdDataGrid, adoSecondaryRs, Me, False, PrintObj, False, nFromPage, nEndPage
        Loop
    End If
End Sub

Public Sub PrintHeader(PrintObj As Object, LMargin As Integer, T_PWidth As Integer)
    Dim sTemp As String
    
    PrintObj.Print
    sTemp = lblDepart.Caption & ": " & DACDepart.Text
    PrintObj.CurrentX = LMargin
    PrintObj.Print sTemp;
    sTemp = lblDate.Caption & ": " & maskDate.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 0.9 / 3#
    PrintObj.Print sTemp;
'    sTemp = Me.lblCheque.Caption & ": " & txtCheque.Text
'    PrintObj.CurrentX = LMargin + T_PWidth * 1.7 / 3#
'    PrintObj.Print sTemp;
    
    sTemp = lblNo.Caption & ": " & txtNo.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 2.4 / 3#
    PrintObj.Print sTemp
    PrintObj.Print
    
    sTemp = Me.lblSupplier.Caption & ": " & Me.txtCustomerName.Text
    PrintObj.CurrentX = LMargin
    PrintObj.Print sTemp;
    sTemp = Me.lblAddress.Caption & ": " & Me.txtCustomerInfo.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 0.9 / 3#
    PrintObj.Print sTemp
    
    sTemp = "凭证编号 " & Me.DacEntryType.Text & " " & txtEntryNo.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 2.4 / 3#
    PrintObj.Print sTemp;

End Sub

Public Sub PrintTail(PrintObj As Object, LMargin As Integer, T_PWidth As Integer, T_PHeight As Integer, Row_Height As Integer, nCurPage As Integer, nTotalPage As Integer)
    Dim sTailText As String
    
    PrintObj.CurrentY = T_PHeight - Row_Height * RowTailCount()
    sTailText = lblHandler.Caption & ": " & txtHandler.Text
    PrintObj.CurrentX = LMargin + 5
    PrintObj.Print sTailText;
    sTailText = "记帐: " & txtKeeper.Text
    PrintObj.CurrentX = LMargin + T_PWidth / 4#
    PrintObj.Print sTailText;
    sTailText = "审核: " & txtAuditer.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 2 / 4#
    PrintObj.Print sTailText;
    sTailText = lblMaker.Caption & ": " & txtMaker.Text
    PrintObj.CurrentX = LMargin + T_PWidth * 3 / 4#
    PrintObj.Print sTailText
    PrintObj.Print
    
    sTailText = "<高特软件>"
    PrintObj.CurrentX = LMargin + 5
    PrintObj.Print sTailText;
    sTailText = Format(m_gLoginDate, "打印日期：YYYY年MM月DD日") & "  第" & nCurPage & "/" & nTotalPage & "页"
    PrintObj.CurrentX = LMargin + T_PWidth - PrintObj.TextWidth(sTailText) - 5
    PrintObj.Print sTailText
End Sub

Property Get RowTailCount() As Integer
    RowTailCount = 3
End Property
Function GetNextNo() As String
Dim rs As ADODB.Recordset
Set rs = New ADODB.Recordset
rs.Open "select max(val(Fno)) as MaxNo from stockup", m_gDBCnn, adOpenStatic, adLockReadOnly
If IsNull(rs!MAxNo) Then
    GetNextNo = "1"
Else
    GetNextNo = Format(Val(rs!MAxNo) + 1)
End If
rs.Close
End Function