frmpsd.frm

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

    '如果存在
    If (Not Rs.EOF) Then
       '数据库中已有此付款单.
       If (Rs("确认状态") = True) Then
          '已经确认不允许修改.
          MsgBox "此配送单已经确认不允许修改", vbExclamation, "提示窗口"
          If (Rs.State = adStateOpen) Then Rs.Close
          Exit Sub
       End If
    End If
    Temp = "您一定要删除表单号为:" & Trim(txtPurcode.Text) & "的配送单吗?"
    If (MsgBox(Temp, vbYesNo + vbDefaultButton2 + vbExclamation) = vbNo) Then
       If (Rs.State = adStateOpen) Then Rs.Close
       Exit Sub
    End If
    '删除
    Cmd.CommandText = "DELETE  FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
    Cmd.Execute
    '确认，删除，前项，后项
    cmdToolCommit.Caption = "弃审[&O]"
    cmdDelete.Enabled = False
    cmdPrev.Enabled = False
    cmdNext.Enabled = False
    '清表
    Call RefreshTable("")
    '提示
    sb1.Panels(1).Text = "配送单已被删除。"
    If (Rs.State = adStateOpen) Then Rs.Close
    Exit Sub
myErr:
    If (Rs.State = adStateOpen) Then Rs.Close
    sb1.Panels(1).Text = "删除配送单失败。"
    MsgBox "删除指配送单时发生错误,信息:" + Err.Description, vbCritical, "错误窗口"
End Sub

'退出
Private Sub cmdExit_Click()
    Unload Me
End Sub

'下一条记录
Private Sub cmdNext_Click()
    On Error GoTo myErr:
    If (Not QueryRs.EOF) Then
       QueryRs.MoveNext
       If (Not QueryRs.EOF) Then
          RefreshTable (QueryRs("表单号"))
       Else
          Call RefreshTable(" ")
          sb1.Panels(1).Text = "已经到查询结果末尾了。"
       End If
    End If
    Exit Sub
myErr:
    MsgBox "在移动到下一表单时发生错误,信息:" + Err.Description, vbCritical
End Sub

'上一条记录
Private Sub cmdPrev_Click()
    On Error GoTo myErr:
    If (Not QueryRs.BOF) Then
       QueryRs.MovePrevious
       If (Not QueryRs.BOF) Then
          RefreshTable (QueryRs("表单号"))
       Else
          Call RefreshTable(" ")
          sb1.Panels(1).Text = "已经到查询结果开头了。"
       End If
    End If
    Exit Sub
myErr:
    MsgBox "在移动到上一表单时发生错误,信息:" + Err.Description, vbCritical
End Sub


'保存表
Private Sub cmdSave_Click()
    Dim sSQL As String
    On Error GoTo myErr
    If Not DataIsOK() Then
        MsgBox "数据存在错误!请检查!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Call CalTotal
    '检查是否存在相同编号供应商编码.
    sSQL = "SELECT * FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    '如果存在
    If Not RsTemp.EOF Then
       If (RsTemp("确认状态") = True) Then
          '供应商编码审批表已经确认不允许修改.
          MsgBox "此单据已经确认不允许修改", vbExclamation, "提示窗口"
          Exit Sub
       Else
          '表未确认,允许修改.
          Temp = "此操作将覆盖原来数据,您确认要继续吗?"
          If (MsgBox(Temp, vbYesNo + vbDefaultButton2 + vbQuestion) = vbNo) Then Exit Sub
       End If
    End If
    '否则代销付款单允许修改.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Cmd.ActiveConnection = Conn
    
    Conn.BeginTrans
    
    If CommSaveTable Then
       '确认事务
       Conn.CommitTrans
       cmdPrev.Enabled = False
       cmdNext.Enabled = False
       cmdToolCommit.Caption = "审核[&O]"
       cmdDelete.Enabled = True
       '提示
        sb1.Panels(1).Text = "PSD已被保存。"
    Else
       '回卷事务
       Conn.RollbackTrans
       '提示
       sb1.Panels(1).Text = "PSD保存失败！"
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Exit Sub
myErr:
    Conn.RollbackTrans
    MsgBox "保存失败." + Chr(13) + "原因:" + Err.Description, vbCritical
End Sub

Private Sub cmdToolSelect_Click()
        Dim I, s, ss, qty, prc
        Load frmSelectGoods
        'frmSelectGoods.GCode = grdDET.Columns("商品编码").Text
        frmSelectGoods.Show 1
        
        If frmSelectGoods.R <> "" Then
            
            sSQL = "select * from 分店商品信息 where 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "' and 分店编码='" & Trim(txtSuppno.Text) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
            
            If Not RsTemp.EOF Then prc = RsTemp("配送价")
            
            sSQL = "SELECT * FROM 商品主档 WHERE 商品编码='" & Trim(frmSelectGoods.GCode) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
            If RsTemp.EOF Then
                MsgBox "该商品编码不存在！" & grdDET.Columns("商品编码").Text & "!", vbExclamation, "提示窗口"
                Exit Sub
            End If
            
            prc = RsTemp("含税进价")
            
            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 & Str(prc) & 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 * prc)
                grdDET.AddItem Temp
            Wend
        End If
        Unload frmSelectGoods

End Sub


'改变确认状态
'只有审核员才能进行该操作
Private Sub cmdToolCommit_Click()
    If cmdToolCommit.Caption = "审核[&O]" Then
        AcceptVil (True)
    Else
        AcceptVil (False)
    End If
End Sub

Private Sub Form_Load()
    Dim sSQL As String
    sSQL = "select  * from inf_sys where paraname='配送单价提示' "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    sSQL = " select * from localmsg "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    If Not RsTemp.EOF Then txtGrpno.Text = RsTemp(1)
    txtIptno.SetConn Conn
    Call RefreshTable(" ")
    Call cmdNew_Click
    
    Cmd.ActiveConnection = Conn
End Sub
'转移焦点
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
    Static KeyFlag As Boolean
    If KeyCode = vbKeyReturn Then SendKeys "{TAB}"
End Sub

Private Sub grdDET_AfterColUpdate(ByVal ColIndex As Integer)
    Call CalTotal
End Sub

Private Sub grdDET_AfterUpdate(RtnDispErrMsg As Integer)
    Call CalTotal
End Sub

Private Sub grdDET_BeforeDelete(Cancel As Integer, DispPromptMsg As Integer)
    DispPromptMsg = False
    If (MsgBox("您一定要删除该行数据吗?", vbQuestion + vbYesNo + vbDefaultButton2) = vbNo) Then
       Cancel = True
    End If
    Call CalTotal
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 grdDET_BeforeColUpdate(ByVal ColIndex As Integer, ByVal OldValue As Variant, Cancel As Integer)
    On Error Resume Next
    Dim sSQL As String
    If QueryFlag Then Exit Sub
    '数据合计
    If ColIndex = 0 Then
        sSQL = " SELECT sum(数量) FROM 配送中心库存 WHERE 商品编码='" & Trim(grdDET.Columns(0).Text) & "'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        If IsNull(RsTemp(0)) Then
           MsgBox "该商品库存不足！" & grdDET.Columns("商品编码").Text & "!", vbExclamation, "提示窗口"
           grdDET.Columns("数量").Value = 0
           'Cancel = 1
           'Exit Sub
        End If
        
        grdDET.Columns("数量").Value = RsTemp(0)
        sSQL = "SELECT * FROM 商品主档 WHERE 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        If RsTemp.EOF Then
            MsgBox "该商品编码不存在！" & grdDET.Columns("商品编码").Text & "!", vbExclamation, "提示窗口"
            Cancel = 1
            Exit Sub
        End If
        grdDET.Columns("商品名称").Text = Trim(RsTemp("品名"))
        grdDET.Columns("单位").Text = Trim(RsTemp("单位"))
        grdDET.Columns("单价").Value = RsTemp("进价")
        
        sSQL = "select * from 分店商品信息 where 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        Set RsTemp = Nothing
        RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
        If Not RsTemp.EOF Then
            grdDET.Columns("单价").Value = RsTemp("配送价")
        End If
    ElseIf ColIndex = 6 Or ColIndex = 5 Then
        grdDET.Columns("金额").Text = CStr(Val(grdDET.Columns("单价").Text) * Val(grdDET.Columns("数量").Text))
        Call CalTotal
'    ElseIf ColIndex = 4 Then
'        Dim I As Single
'        I = InputBox("加点", "", 0)
'        If I <> 0 Then grdDET.Columns(4).Value = grdDET.Columns(4).Value * (1 + I / 100)
'        grdDET.Columns(7).Text = CStr(Val(grdDET.Columns(6).Text) * Val(grdDET.Columns(3).Text))
'        grdDET.Columns(5).Text = CStr(Val(grdDET.Columns(4).Text) * Val(grdDET.Columns(3).Text))
'        Call CalTotal
    End If
End Sub


'进行合计
Private Sub CalTotal()
    Dim I As Integer
    txtIamt.Text = "0"
    txtIamt0.Text = ""
    For I = 0 To grdDET.Rows - 1
        txtIamt0.Text = CStr(Val(txtIamt0.Text) + Val(grdDET.Columns(3).CellText(I)))
        txtIamt.Text = CStr(Val(txtIamt.Text) + Val(grdDET.Columns(5).CellText(I)))
    Next I
    txtIamt.Text = Format(txtIamt.Text, "#.00")
End Sub

Private Sub grdDET_RowColChange(ByVal LastRow As Variant, ByVal LastCol As Integer)
    Call CalTotal
End Sub


Private Sub txtPurcode_Validate(Cancel As Boolean)
    Dim sSQL As String
    Dim Rs As New ADODB.Recordset
    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 " & TableName & " 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(txtPurcode.Text)
        Else
            txtPurcode.SelStart = 0
            txtPurcode.SelLength = Len(txtPurcode.Text)
            Cancel = True
        End If
    End If
End Sub

'日期格式转换
Private Sub txtPurdate_GotFocus()
    txtPurdate.ZOrder 0
End Sub

Private Sub txtSuppno_CloseUp()
    txtSuppName.Text = txtSuppno.Columns(1).Text
End Sub

Private Sub txtSuppno_GotFocus()
    txtSuppno.DroppedDown = True
End Sub

Private Sub txtSuppno_InitColumnProps()
    On Error GoTo LinkErr
    Dim Rs As New ADODB.Recordset
    Set Rs = Nothing
    Rs.Open "SELECT * FROM 分店主档 order by 分店编码", Conn, adOpenStatic, adLockReadOnly
    While Not Rs.EOF
        txtSuppno.AddItem Rs("分店编码") & vbTab & Rs("分店名称")
        Rs.MoveNext
    Wend
    Exit Sub
LinkErr:
    MsgBox "初始化数据错误！" & Err.Description, vbExclamation, "错误窗口"
End Sub