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 = "LSChainXSD已被保存。"
    Else
       '回卷事务
       Conn.RollbackTrans
       '提示
       sb1.Panels(1).Text = "LSChainXSD保存失败！"
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Exit Sub
MyErr:
    Conn.RollbackTrans
    MsgBox "保存失败." + Chr(13) + "原因:" + Err.Description, vbCritical
End Sub

Private Sub cmdToolJian_Click()
    Dim s, ss, Qty, prc, I
    If txtSuppno.Text = "" Then
        MsgBox "请先选择分店!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Load frmDist
    'Set frmDist.frm = Me
    frmDist.Show 1
    sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & frmDist.GCode & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
        MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
        Exit Sub
    End If
        If frmDist.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(frmDist.GCode) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
            If RsTemp.EOF Then
                MsgBox "该商品编码不存在！" & grdDET.Columns("商品编码").Text & "!", vbExclamation, "提示窗口"
                Exit Sub
            End If
            
            Load frmChainPrc
            Call frmChainPrc.InitData(frmDist.GCode, txtSuppno.Text)
            frmChainPrc.Show 1
            prc = frmChainPrc.prc
            
            ss = frmDist.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 = frmDist.GCode & vbTab & RsTemp("品名") & vbTab & _
                        RsTemp("单位") & vbTab & s & vbTab & Str(Qty * prc)
                grdDET.AddItem Temp
            Wend
        End If
        Unload frmDist

End Sub


'改变确认状态
'只有审核员才能进行该操作
Private Sub cmdToolCommit_Click()
    If GetSetting("LSDSTAR", "库存设置", "使用存储过程", "1") = "0" Then
        If cmdToolCommit.Caption = "审核[&O]" Then
            AcceptVil (True)
        Else
            AcceptVil (False)
        End If
    Else
        Cmd.ActiveConnection = Conn
        If cmdToolCommit.Caption = "审核[&O]" Then
            Cmd.CommandText = "P_INStoreBill '审核','PSD','" & Trim(txtPurcode.Text) & "'"
            
        Else
            Cmd.CommandText = "P_INStoreBill '弃审','PSD','" & Trim(txtPurcode.Text) & "'"
            
        End If
        Cmd.ActiveConnection = Conn
        Cmd.Execute
        
        
        If cmdToolCommit.Caption = "审核[&O]" Then
            Cmd.CommandText = "P_INChainStoreBill '审核','PSD','" & Trim(txtPurcode.Text) & "'"
            Call SetButtonState(True)
        Else
            Cmd.CommandText = "P_INChainStoreBill '弃审','PSD','" & Trim(txtPurcode.Text) & "'"
            Call SetButtonState(False)
        End If
        Cmd.ActiveConnection = Conn
        Cmd.Execute
    End If
End Sub

Private Sub cmdToolSelect_Click()
    Dim s, ss, Qty, prc, I
    On Error Resume Next
    If txtSuppno.Text = "" Then
        MsgBox "请先选择分店!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    
    Load frmChainSelectGoods
    frmChainSelectGoods.SType = "配送"
    frmChainSelectGoods.ChainCode = txtSuppno.Text
    frmChainSelectGoods.Show 1
    sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & frmChainSelectGoods.GCode & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
        MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
        Exit Sub
    End If
    
    grdDET.Update
    
    If frmChainSelectGoods.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(frmChainSelectGoods.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("含税进价")
        
'        Load frmChainPrc
'        Call frmChainPrc.InitData(frmChainSelectGoods.GCode, txtSuppno.Text)
'        frmChainPrc.Show 1
'        prc = frmChainPrc.prc
        
'        If GetSetting("LSDSTAR", "库存设置", "配送单加点提示", "1") = "1" Then
'            Load frmChainPrc
'            Call frmChainPrc.InitData(frmChainSelectGoods.GCode, txtSuppno.Text)
'            frmChainPrc.Show 1
'            prc = frmChainPrc.prc
'        Else
'            prc = frmChainSelectGoods.vPrc
'        End If

        
        ss = frmChainSelectGoods.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 = frmChainSelectGoods.GCode & vbTab & RsTemp("品名") & vbTab & _
                    RsTemp("单位") & vbTab & s & vbTab & Str(Qty * prc)
            grdDET.AddItem Temp
        Wend
    End If
    Unload frmChainSelectGoods

End Sub

Private Sub Form_Load()
    Dim sSQL As String
    sSQL = "select  * from inf_sys where paraname='配送单价提示' "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    
    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 cmdToolCommit.Caption = "弃审[&O]" Then
        Cancel = True
        Exit Sub