frm+

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

    End If
    '否则代销付款单允许修改.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Cmd.CommandText = " begin tran "
    Cmd.Execute
    If CommSaveTable Then
       '确认事务
       Cmd.CommandText = " commit tran "
       Cmd.Execute
       cmdPrev.Enabled = False
       cmdNext.Enabled = False
       cmdVil.Enabled = True
       cmdDelete.Enabled = True
       '提示
        sb1.Panels(1).Text = "商品配送单已被保存。"
    Else
       '回卷事务
       Cmd.CommandText = " rollback tran "
       Cmd.Execute
       '提示
       sb1.Panels(1).Text = "商品配送单保存失败！"
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Exit Sub
MyErr:
    Cmd.CommandText = " rollback tran "
    Cmd.Execute
    MsgBox "保存失败." + Chr(13) + "原因:" + Err.Description, vbCritical
End Sub

Private Sub cmdToolUnCommit_Click()
    On Error GoTo ComErr
    Dim i As Integer
    Dim TempSum As Single
    Dim TempPrc As Single
    Dim TempIPrc As Single
    Dim TempTIPrc As Single
    Dim sSQL As String
    Dim strOperMsg As String
    If Not DataIsOK() Then
        MsgBox "表单数据存在错误!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Temp = "确定要弃审该单据吗?"
    If MsgBox(Temp, vbQuestion & vbYesNo, "提示窗口") = vbNo Then Exit Sub
    
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Cmd.CommandText = " begin tran "
    Cmd.Execute
    sSQL = "UPDATE " & TableName & " SET 确认状态=0 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Cmd.CommandText = sSQL
    Cmd.Execute
    grdDET.MoveFirst
    For i = 0 To grdDET.Rows - 1
        sSQL = "select * from 商品主档 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        TempIPrc = RsTemp("进价")
        TempTIPrc = RsTemp("含税进价")
        TempPrc = grdDET.Columns(4).Value   'RsTemp("零售价")
        
        sSQL = "update 配送中心库存 set 数量=数量+(" & grdDET.Columns(3).Value & ")," & _
        "进价金额=进价金额+(" & grdDET.Columns(3).Value * TempIPrc & "),售价金额=售价金额-(" & grdDET.Columns(3).Value * TempPrc & "),含税进价金额=含税进价金额+(" & grdDET.Columns(3).Value * TempTIPrc & ")" & _
        " where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销'"
        If RunSQL(sSQL) <> 0 Then GoTo ComErr
        Set RsTemp = Nothing
        sSQL = "select * from 分店库存 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        Set RsTemp = OpenRS(sSQL)
        sSQL = "update 分店库存 set 数量=数量-(" & grdDET.Columns(3).Value & ")," & _
                 " 进价金额=进价金额-(" & grdDET.Columns(3).Value * TempIPrc & "),售价金额=售价金额-(" & grdDET.Columns(3).Value * TempPrc & "),含税进价金额=含税进价金额-(" & grdDET.Columns(3).Value * TempTIPrc & ")" & _
                 " where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        If RunSQL(sSQL) <> 0 Then GoTo ComErr
        
        grdDET.MoveNext
    Next i
    '确认，保存，删除
    cmdVil.Enabled = True
    cmdSave.Enabled = True
    cmdDelete.Enabled = True
    cmdToolUnCommit.Enabled = False
    Cmd.CommandText = " commit tran "
    Cmd.Execute
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    strOperMsg = strOperMsg & vbCrLf & "弃审成功!"
    Exit Sub
ComErr:
    ErrNum = Err.number
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = " rollback tran "
    Cmd.Execute
    MsgBox "弃审失败!,请检查数据是否正确!" & vbCrLf & Error$(Err.number), vbExclamation, "提示窗口"
End Sub

'改变确认状态
'只有审核员才能进行该操作
Private Sub cmdVil_Click()
    On Error GoTo ComErr
    Dim i As Integer
    Dim TempSum As Single
    Dim TempPrc As Single
    Dim TempIPrc As Single
    Dim TempTIPrc As Single
    Dim sSQL As String
    Dim strOperMsg As String
    If Not DataIsOK() Then
        MsgBox "表单数据存在错误!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Temp = "确认之后将不能再作改动,继续吗?"
    If MsgBox(Temp, vbQuestion & vbYesNo, "提示窗口") = vbNo Then Exit Sub
    If Not CommSaveTable() Then
       MsgBox "保存数据时发生错误!", vbExclamation, "错误窗口"
       Exit Sub
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Cmd.CommandText = " begin tran "
    Cmd.Execute
    sSQL = "UPDATE " & TableName & " SET 确认状态=1 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Cmd.CommandText = sSQL
    Cmd.Execute
    grdDET.MoveFirst
    For i = 0 To grdDET.Rows - 1
        sSQL = "select * from 商品主档 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        TempIPrc = RsTemp("进价")
        TempTIPrc = RsTemp("含税进价")
        TempPrc = grdDET.Columns(4).Value    'RsTemp("零售价")
        sSQL = "select 数量 from 配送中心库存 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        '如果现存数量小于配送数量
'        If RsTemp(0) < grdDET.Columns(3).Value Then GoTo ComErr
        sSQL = "update 配送中心库存 set 数量=数量-(" & grdDET.Columns(3).Value & ")," & _
        "进价金额=进价金额-(" & grdDET.Columns(3).Value * TempIPrc & "),售价金额=售价金额+(" & grdDET.Columns(3).Value * TempPrc & "),含税进价金额=含税进价金额-(" & grdDET.Columns(3).Value * TempTIPrc & ")" & _
        " where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销'"
        If RunSQL(sSQL) <> 0 Then GoTo ComErr
        Set RsTemp = Nothing
        sSQL = "select * from 分店库存 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        Set RsTemp = OpenRS(sSQL)
        If RsTemp.EOF Then
           sSQL = "insert into 分店库存 (分店编码,商品编码,品名,数量,进价金额,售价金额,单位,经营方式,含税进价金额) values('" & _
                   txtSuppno.Text & "','" & grdDET.Columns(0).Text & "','" & grdDET.Columns(1).Text & "'," & grdDET.Columns(3).Value & "," & _
                   grdDET.Columns(3).Value * TempIPrc & "," & grdDET.Columns(3).Value * TempPrc & ",'" & grdDET.Columns(2).Text & "','经销'," & _
                   grdDET.Columns(3).Value * TempTIPrc & ")"
           If RunSQL(sSQL) <> 0 Then GoTo ComErr
        Else
           sSQL = "update 分店库存 set 数量=数量+(" & grdDET.Columns(3).Value & ")," & _
                 " 进价金额=进价金额+(" & grdDET.Columns(3).Value * TempIPrc & "),售价金额=售价金额+(" & grdDET.Columns(3).Value * TempPrc & "),含税进价金额=含税进价金额+(" & grdDET.Columns(3).Value * TempTIPrc & ")" & _
                 " where 商品编码='" & Trim(grdDET.Columns(0).Text) & "'" & " and 经营方式='经销' and 分店编码='" & Trim(txtSuppno.Text) & "'"
           If RunSQL(sSQL) <> 0 Then GoTo ComErr
        End If
        
        ''''''''''''''''''''''''''''''''''''
        '设置分店商品信息
        sSQL = "select * from 分店商品信息 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        Set RsTemp = Nothing
        RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
        If RsTemp.EOF Then RsTemp.AddNew
        RsTemp("分店编码") = Trim(txtSuppno.Text)
        RsTemp("商品编码") = Trim(grdDET.Columns(0).Text)
        RsTemp("配送价") = Val(grdDET.Columns(4).Text)
        RsTemp.Update
        
        ''''''''''''''''''''''''''''''''''''
        
        grdDET.MoveNext
    Next i
    '确认，保存，删除
    cmdVil.Enabled = False
    cmdSave.Enabled = False
    cmdDelete.Enabled = False
    cmdToolUnCommit.Enabled = True
    Cmd.CommandText = " commit tran "
    Cmd.Execute
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    strOperMsg = strOperMsg & vbCrLf & "配送成功!"
'    Load frm运行结果
'    frm运行结果!txt结果.Text = strOperMsg
'    frm运行结果.Show 1
    Exit Sub
ComErr:
    ErrNum = Err.number
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = " rollback tran "
    Cmd.Execute
    MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(Err.number), vbExclamation, "提示窗口"
End Sub

Private Sub Form_Load()
    Dim sSQL As String
    sSQL = "select  * from inf_sys where paraname='配送单价提示' "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    If Not RsTemp.EOF Then
       optS.Value = IIf(Left(RsTemp(1), 1) = "0", True, False)
       optJ.Value = IIf(Left(RsTemp(1), 1) = "1", True, False)
    End If
    sSQL = " select * from localmsg "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
'    txtGrpno.Text = ""
    If Not RsTemp.EOF Then txtGrpno.Text = RsTemp(1)
    txtIptno.SetConn Conn
    Me.Top = 0
    Me.Left = 100
    Call RefreshTable(" ")
    Call cmdNew_Click
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(0).Text & "!", vbExclamation, "提示窗口"
           grdDET.Columns(3).Value = 0
           'Cancel = 1
           'Exit Sub
        End If
        
        grdDET.Columns(3).Value = RsTemp(0)
        sSQL = "SELECT * FROM 商品主档 WHERE 商品编码='" & Trim(grdDET.Columns(0).Text) & "'"
        Set RsTemp = Nothing
        Set RsTemp = OpenRS(sSQL)
        If RsTemp.EOF Then
            MsgBox "该商品编码不存在！" & grdDET.Columns(0).Text & "!", vbExclamation, "提示窗口"
            Cancel = 1
            Exit Sub
        End If
        grdDET.Columns(1).Text = Trim(RsTemp("品名"))
        grdDET.Columns(2).Text = Trim(RsTemp("单位"))
        grdDET.Columns(6).Value = RsTemp("进价")
        grdDET.Columns(4).Value = IIf(optS.Value, RsTemp("零售价"), RsTemp("进价"))
        grdDET.Columns(8).Value = RsTemp("含税进价")
        
        sSQL = "select * from 分店商品信息 where 商品编码='" & Trim(grdDET.Columns(0).Text) & "' and 分店编码='" & Trim(txtSuppno.Text) & "'"
        Set RsTemp = Nothing
        RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
        If Not RsTemp.EOF Then
            grdDET.Columns(4).Value = RsTemp("配送价")
        End If
    ElseIf ColIndex = 3 Then
        'sSQL = " SELECT sum(数量) FROM 配送中心库存 WHERE 商品编码='" & Trim(grdDET.Columns(0).Text) & "'"
        'Set RsTemp = Nothing
        'Set RsTemp = OpenRS(sSQL)
        'If grdDET.Columns(3).Value > RsTemp(0) Then
        '   MsgBox "该商品库存不足！" & grdDET.Columns(0).Text & "!", vbExclamation, "提示窗口"
        '   Cancel = 1
        '   Exit Sub
        'End If
        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
    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