frmpdd.frm

注释：用VB开发的进销存系统源码

        grdDET.Update
        Call GenerateQuerySQL

        Set Rs = Nothing
        Rs.CursorLocation = adUseClient
        Rs.Open sSQL, Conn, adOpenStatic, adLockOptimistic
        If Rs.EOF Then
            MsgBox "无匹配记录!", vbInformation, "提示窗口"
            cmdToolPrevious.Enabled = False
            cmdToolNext.Enabled = False
            Exit Sub
        End If
        sSQL = "SELECT * FROM LSPDD WHERE 表单号='" & Trim(Rs(0)) & "'"
        Set RsTemp = Nothing
        RsTemp.Open sSQL, Conn, adOpenStatic, adLockPessimistic
        Call RefreshTable(RsTemp)
        Call ShowStatus(0)
    End If
End Sub


'下一条记录
Private Sub cmdToolNext_Click()
    On Error Resume Next
    If Rs.State = adStateClosed Then Exit Sub
    If Not Rs.EOF Then
        Rs.MoveNext
        Call ShowStatus(0)
        If Not Rs.EOF Then
            sSQL = "SELECT * FROM LSPDD WHERE 表单号='" & Trim(Rs(0)) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
            
            Call RefreshTable(RsTemp)
        Else
            Call ClearTable
        End If
    End If
End Sub

'上一条记录
Private Sub cmdToolPrevious_Click()
    On Error Resume Next
    If Rs.State = adStateClosed Then Exit Sub
    If Not Rs.BOF Then
        Rs.MovePrevious
        Call ShowStatus(0)
        If Not Rs.BOF Then
            sSQL = "SELECT * FROM LSPDD WHERE 表单号='" & Trim(Rs(0)) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
            
            Call RefreshTable(RsTemp)
        Else
            Call ClearTable
        End If
    End If
End Sub



'刷新表
Private Sub cmdToolSave_Click()
    On Error GoTo RefErr
    If Not DataOK() Then
        MsgBox "数据存在错误!请检查!", vbExclamation, "提示窗口"
        Exit Sub
    End If
   
    Conn.BeginTrans
    Call ShowStatus(3)
    Call CalTotalDelete
    '开始事务
    sSQL = "SELECT * FROM LSPDD WHERE 表单号='" & txtPurcode.Text & "'"
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    If Not RsTemp.EOF Then
        Temp = "该表单已经存在，覆盖原表单吗？"
        Temp = MsgBox(Temp, vbOKCancel + vbQuestion, "提示窗口")
        If Temp = vbCancel Then
            Conn.RollbackTrans
            Exit Sub
        End If

        '生成SQL语句,删除表头旧数据
        sSQL = "DELETE  FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
        If RunSQL(sSQL) <> 0 Then
            MsgBox "更新失败!请检查数据的合法性!" & vbCrLf & Error$(ErrNum), vbExclamation, "警告窗口"
            Conn.RollbackTrans
            Exit Sub
        End If
        
    End If
    If SaveTable() Then
        '确认事务
        Conn.CommitTrans
        cmdToolPrevious.Enabled = False
        cmdToolCommit.Caption = "审核[&O]"
        cmdToolNext.Enabled = False
        cmdToolDelete.Enabled = True
    Else
        Temp = "在对数据库进行写操作时发生错误!" & vbCrLf & _
        "请检查是否存在重复的编码或编码格式是否正确!"
        MsgBox Temp, vbExclamation + vbOKOnly, "错误提示窗口"
        '事务回卷
        Conn.RollbackTrans
    End If
    Exit Sub
RefErr:
    ErrNum = Err.number
    MsgBox "更新数据库发生错误!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"
End Sub


Private Sub Form_Activate()
    txtPurcode.SetFocus
End Sub

'转移焦点
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    
    If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
    If (Shift And vbCtrlMask) And KeyCode = vbKeyReturn Then
        cmdToolSelect_Click
    End If
End Sub


Private Sub Form_Load()
   Call SetFormToCenter(Me)
    txtIptno.SetConn Conn
    txtIptno.TableName = ClerkInfo
    txtIptno.CodeField = ClerkCode
    txtIptno.NameField = ClerkName
    
    grdDET.Columns("含税进价").NumberFormat = DecNum
    grdDET.Columns("不含税进价").NumberFormat = DecNum
    grdDET.Columns("含税进价金额").NumberFormat = DecNum
    grdDET.Columns("不含税进价金额").NumberFormat = DecNum
    
    AutoGeneratePurcode = GetSetting("LSDSTAR", "进销管理", "进货单单号是否自动生成", "0")
    
    On Error Resume Next
    TableState = "新建"
    grdDET.AllowUpdate = True
    grdDET.SelectByCell = False
    Set Rs = Nothing
    QueryFlag = False
    Call ShowStatus(2)
    '清除整个表显示
    Call ClearTable
    txtIptno.Text = UserCode
    If AutoGeneratePurcode = "TRUE" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If
'    txtPurcode.SetFocus
    cmdToolSave.Enabled = True
    cmdToolPrevious.Enabled = False
    cmdToolNext.Enabled = False
    cmdToolDelete.Enabled = False
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    If GetSetting("LSDSTAR", "进销管理", "进货单单号是否自动生成", "1") = "1" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If
    txtIptno.Text = UserCode

End Sub



'进行合计
Private Sub CalTotalDelete()
    Dim vBm As Variant
    Dim Qty, Iamt, Ramt
    Dim I As Integer
    
    vBm = grdDET.Bookmark
    grdDET.MoveFirst
    
    For I = 0 To grdDET.Rows - 1
        Qty = Qty + grdDET.Columns("数量").CellValue(grdDET.GetBookmark(I))
        Iamt = Iamt + grdDET.Columns("不含税进价金额").CellValue(grdDET.GetBookmark(I))
        Ramt = Ramt + grdDET.Columns("含税进价金额").CellValue(grdDET.GetBookmark(I))
    Next I
    
    txtQty.Text = CStr(Qty)
    txtIamt0.Text = CStr(Iamt)
    txtIamt.Text = CStr(Ramt)
    
    grdDET.Bookmark = vBm

End Sub


Private Sub Form_Unload(Cancel As Integer)
    Set Rs = Nothing
End Sub


Private Sub grdDET_AfterDelete(RtnDispErrMsg As Integer)
    Call CalTotalDelete
End Sub

Private Sub grdDET_AfterUpdate(RtnDispErrMsg As Integer)
    Call CalTotalDelete
    grdDET.Columns("尺寸").RemoveAll
    grdDET.Columns("颜色").RemoveAll
End Sub

Private Sub grdDET_BeforeDelete(Cancel As Integer, DispPromptMsg As Integer)
    DispPromptMsg = False
    If cmdToolCommit.Caption = "弃审[&O]" Then
        Cancel = True
        Exit Sub
    End If
    If (MsgBox("您一定要删除选定行数据吗?", vbQuestion + vbYesNo + vbDefaultButton2) = vbNo) Then
        Cancel = True
    End If
End Sub

'判断商品编码是否已经存在
'进行数据合计
Private Sub grdDET_BeforeColUpdate(ByVal ColIndex As Integer, ByVal OldValue As Variant, Cancel As Integer)
    On Error GoTo FormatErr
    If QueryFlag Then Exit Sub
    Select Case grdDET.Columns(ColIndex).Name
        Case "商品编码"
                '进行数据合法性检查
            sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & grdDET.Columns(ColIndex).Text & "'"
            Set RsTemp = Nothing
            Set RsTemp = OpenRS(sSQL)
            If RsTemp.EOF Then
                MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
                Cancel = 1
            Else
                grdDET.Columns("品名").Text = RsTemp("品名")
                grdDET.Columns("单位").Text = RsTemp("单位")
                grdDET.Columns("单位").Value = RsTemp("单位")
'                If RsTemp("税率") <> 0 Then
'                    grdDET.Columns("税率").Value = RsTemp("税率")
'                Else
                    grdDET.Columns("税率").Value = 17
'                End If
                grdDET.Columns("不含税进价").Value = RsTemp("进价")
                grdDET.Columns("含税进价").Value = RsTemp("含税进价")
                
                sSQL = "SELECT 尺寸 FROM 商品信息 where 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "' group by 尺寸"
                Set RsTemp = Nothing
                RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
                grdDET.Columns("尺寸").RemoveAll
                While Not RsTemp.EOF
                    grdDET.Columns("尺寸").AddItem RsTemp("尺寸")
                    RsTemp.MoveNext
                Wend
                sSQL = "SELECT 颜色 FROM 商品信息 where 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "' group by 颜色 "
                Set RsTemp = Nothing
                RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
                grdDET.Columns("颜色").RemoveAll
                While Not RsTemp.EOF
                    grdDET.Columns("颜色").AddItem RsTemp("颜色")
                    RsTemp.MoveNext
                Wend

                Cancel = 0
            End If

        Case "数量"
            grdDET.Columns("不含税进价金额").Value = Format(grdDET.Columns("不含税进价").Value * grdDET.Columns("数量").Value, DecNum)
            grdDET.Columns("含税进价金额").Value = Format(grdDET.Columns("含税进价").Value * grdDET.Columns("数量").Value, DecNum)
        Case "含税进价"
            grdDET.Columns("含税进价金额").Value = Format(grdDET.Columns("含税进价").Value * grdDET.Columns("数量").Value, DecNum)
            grdDET.Columns("不含税进价").Value = Format(grdDET.Columns("含税进价").Value / (1 + (grdDET.Columns("税率").Value / 100)), DecNum)
            grdDET.Columns("不含税进价金额").Value = Format(grdDET.Columns("不含税进价").Value * grdDET.Columns("数量").Value, DecNum)
        Case "售价"
            grdDET.Columns("售价金额").Value = Format(grdDET.Columns("售价").Value * grdDET.Columns("数量").Value, DecNum)
        Case "含税进价金额"
            If grdDET.Columns("数量").Value = 0 Then
                MsgBox "数量不能为零", vbInformation, "提示窗口"
                Exit Sub
            End If
            grdDET.Columns("含税进价").Value = Format(grdDET.Columns("含税进价金额").Value / grdDET.Columns("数量").Value, DecNum)
            grdDET.Columns("含税进价金额").Value = Format(grdDET.Columns("含税进价").Value * grdDET.Columns("数量").Value, DecNum)
            grdDET.Columns("不含税进价").Value = Format(grdDET.Columns("含税进价").Value / (1 + (grdDET.Columns("税率").Value / 100)), DecNum)
            grdDET.Columns("不含税进价金额").Value = Format(grdDET.Columns("不含税进价").Value * grdDET.Columns("数量").Value, DecNum)
        Case "零售金额"
            If grdDET.Columns("数量").Value = 0 Then
                MsgBox "数量不能为零", vbInformation, "提示窗口"
                Exit Sub
            End If
            grdDET.Columns("售价").Value = Format(grdDET.Columns("零售价金额").Value / grdDET.Columns("数量").Value, DecNum)
       
    End Select
    
    Exit Sub
FormatErr:
    ErrNum = Err.number
    Cancel = 1
End Sub


Private Sub cmdToolSelect_Click()
        Dim I, s, ss, Qty
        Load frmSelectGoods
        'frmSelectGoods.GCode = grdDET.Columns("商品编码").Text
        frmSelectGoods.Show 1
        sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & frmSelectGoods.GCode & "'"
        Set RsTemp = Nothing
        RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
        
        If RsTemp.EOF Then
            MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
            Exit Sub
        End If
        grdDET.Update
        If frmSelectGoods.R <> "" Then
            ss = frmSelectGoods.R
            
            I = 1
            While I <= Len(ss)
                s = ""
                Qty = ""
                While Mid(ss, I, 1) <> "#" And I <= Len(ss)
                    If Mid(ss, I, 1) = "@" Then
                        s = s & vbTab
                    ElseIf Mid(ss, I, 1) = "$" Then
                        Qty = ""
                        s = s & vbTab & RsTemp("含税进价") & vbTab & RsTemp("进价") & vbTab & "17" & vbTab
                    Else
                        Qty = Qty & Mid(ss, I, 1)
                        s = s & Mid(ss, I, 1)
                    End If
                    I = I + 1
                Wend
                I = I + 1
                Temp = frmSelectGoods.GCode & vbTab & RsTemp("品名") & vbTab & _
                        RsTemp("单位") & vbTab & s & vbTab & Str(Qty * RsTemp("含税进价")) & vbTab & Str(Qty * RsTemp("进价"))
                grdDET.AddItem Temp
            Wend
        End If
        Unload frmSelectGoods

End Sub

Private Sub grdDET_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyDown Then grdDET.ComboDroppedDown = True
End Sub

Private Sub txtIptno_GotFocus()
    If Not QueryFlag Then SendKeys "{TAB}"
End Sub

Private Sub txtIptno_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
End Sub


Private Sub txtPurcode_Validate(Cancel As Boolean)
    If QueryFlag Then Exit Sub
    If TableState <> "新建" Then Exit Sub
    If Len(txtPurcode.Text) <> 7 Then
        MsgBox "表单号位数不够！", vbExclamation, "提示窗口"
        Cancel = True
        Exit Sub
    End If

    sSQL = "SELECT * FROM LSPDD WHERE 表单号='" & txtPurcode.Text & "'"
    Set RsTemp = OpenRS(sSQL)
    '记录集为空则退出
    If RsTemp.EOF Then
        Cancel = False
        Exit Sub
    ElseIf grdDET.Rows = 0 Then
        Temp = "该表单已经存在!" & vbCrLf & "显示该表单吗?"
        Temp = MsgBox(Temp, vbExclamation + vbYesNo, "提示窗口")
        If Temp = vbYes Then
            Set Rs = Nothing
            Set Rs = RsTemp
            Call RefreshTable(Rs)
        Else
            txtPurcode.SelStart = 0
            txtPurcode.SelLength = Len(txtPurcode.Text)
            Cancel = True
        End If
    End If
End Sub


Private Sub txtPurdate_Validate(Cancel As Boolean)
    Dim t
    On Error GoTo DateErr
    t = CDate(txtPurdate.Text)
    txtPurdate.Text = Format(txtPurdate.Text, "yyyy-mm-dd")
    Cancel = False
    Exit Sub
DateErr:
    Cancel = True
End Sub