frmlspsd.frm

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

       MsgBox "保存数据时发生错误!", vbExclamation, "错误窗口"
       Exit Function
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Conn.BeginTrans
    
    If d Then
        sSQL = "UPDATE " & TableName & " SET 确认状态=1 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Else
       sSQL = "UPDATE " & TableName & " SET 确认状态=0 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    End If
    
    Cmd.CommandText = sSQL
    Cmd.Execute
    
    
    sSQL = "select 商品编码,品名,单位,颜色,尺寸,配送数量 as 数量,零售价 as 单价 from psd where 表单号='" & Trim(txtPurcode.Text) & "'"
    Set RsS = Nothing
    RsS.Open sSQL, Conn, adOpenStatic, adLockReadOnly

    
    While Not RsS.EOF
        If d Then
            Qty = -RsS("数量")
        Else
            Qty = RsS("数量")
        End If
        
        If Not OutStock(RsS("商品编码"), RsS("品名"), RsS("单位"), _
                 RsS("颜色"), RsS("尺寸"), Qty) Then
            MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"
            Conn.RollbackTrans
            Exit Function
        End If
        
        
        If Not InSubStock(txtSuppno, RsS("商品编码"), RsS("品名"), _
              RsS("单位"), RsS("颜色"), RsS("尺寸"), _
               -Qty, RsS("单价"), 0) Then
            MsgBox "确认失败!,请检查数据是否正确!", vbInformation, "提示窗口"
            Conn.RollbackTrans
            Exit Function
        End If
        RsS.MoveNext
    Wend

    
    
    '确认，保存，删除
    Call SetButtonState(d)
        
    If GetSetting("LSDSTAR", "库存设置", "显示订单", "1") = "1" Then
       Call VilDD(d)
    End If
    
    Conn.CommitTrans
    Exit Function
ComErr:
    ErrNum = Err.number
    Conn.RollbackTrans
    MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(Err.number), vbExclamation, "提示窗口"
End Function

Private Sub ShowPosition()
    On Error Resume Next
    sb1.Panels(1).Text = "共" & Trim(Str(QueryRs.RecordCount)) & "条,第:" & Trim(Str(QueryRs.AbsolutePosition)) & "条"
End Sub

'进入查询状态
Private Sub BeginQuery()
    cmdNew.Enabled = False
    cmdSave.Enabled = False
    cmdToolCommit.Caption = "弃审[&O]"
    cmdDelete.Enabled = False
    QueryFlag = True
    cmdQuery.Caption = "开始[&Q]"
End Sub

'恢复查询前的状态
Private Sub RestoreState()
    Call RefreshTable(" ")
    cmdNew.Enabled = True
    cmdSave.Enabled = True
    cmdToolCommit.Caption = "审核[&O]"
    cmdDelete.Enabled = True
    cmdQuery.Caption = "查询[&Q]"
End Sub

'完成查询
Private Sub CommitQuery()
    On Error GoTo MyErr
    Dim strSQL As String
    Dim strTemp As String
    strSQL = "SELECT 表单号 FROM " & TableName & " WHERE "
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If (Trim(txtPurcode.Text) <> "") Then
       strTemp = "表单号 LIKE '" & Trim(txtPurcode.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    '配送日期
    If (Trim(txtPurdate.Text) <> "") Then
       strTemp = " 配送日期 = '" & Trim(txtPurdate.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    If Trim(grdDET.Columns(1).Text) <> "" Then
       strTemp = " 商品编码 like '" & Trim(grdDET.Columns(1).Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    '录入员
    If (Trim(txtIptno.Text) <> "") Then
       strTemp = "录入员 LIKE '" & Trim(txtIptno.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    If (Trim(txtSuppno.Text) <> "") Then
       strTemp = "分店编码 LIKE '" & Trim(txtSuppno.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If (Right(Trim(strSQL), 5) = "WHERE") Then
       strSQL = Left(Trim(strSQL), Len(Trim(strSQL)) - 5)
    Else
        strSQL = Left(Trim(strSQL), Len(Trim(strSQL)) - 3)
    End If
    strSQL = strSQL & "  group by 表单号  order by  表单号 desc "
    RestoreState
    Set QueryRs = Nothing
    QueryRs.CursorLocation = adUseClient
    QueryRs.Open strSQL, Conn, adOpenDynamic, adLockReadOnly
    If (Not QueryRs.EOF) Then
       RefreshTable (QueryRs("表单号"))
       cmdPrev.Enabled = True
       cmdNext.Enabled = True
    Else
       Call RefreshTable("")
       cmdPrev.Enabled = False
       cmdNext.Enabled = False
    End If
    Exit Sub
MyErr:
    MsgBox "查询条件或者数据库发生错误,请检查." & Chr(13) & "错误信息:" & Err.Description, vbCritical
End Sub

Private Function CommSaveTable() As Boolean
    Dim sSQL As String
    On Error GoTo CommSaveErr
    sSQL = "DELETE FROM " & TableName & " WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    If SaveTable() Then
        CommSaveTable = True
        Exit Function
    Else
        CommSaveTable = False
        Exit Function
    End If
    Exit Function
CommSaveErr:
    CommSaveTable = False
End Function
'
'检查数据是否合法
Private Function DataIsOK() As Boolean
    If Trim(txtPurcode.Text) = "" Then
        DataIsOK = False
        Exit Function
    End If
    If Trim(txtGrpno.Text) = "" Then
        DataIsOK = False
        Exit Function
    End If
    If Trim(txtPurdate.Text) = "" Then
        DataIsOK = False
        Exit Function
    End If
    If Trim(txtSuppno.Text) = "" Then
        DataIsOK = False
        Exit Function
    End If
    If Trim(txtIptno.Text) = "" Then
        DataIsOK = False
        Exit Function
    End If
    If grdDET.Rows = 0 Then
        DataIsOK = False
        Exit Function
    End If
    DataIsOK = True
    
End Function

'刷新表显示

Private Sub RefreshTable(ID As String)
    On Error GoTo MyErr
    Dim sSQL As String
    Dim strSQL As String
    Dim vRs As New ADODB.Recordset
    Dim Temp As String
    strSQL = "SELECT * FROM " & TableName & " WHERE 表单号='" & Trim(ID) & "' ORDER BY 商品编码,尺寸"
    Set vRs = Nothing
    vRs.Open strSQL, Conn, adOpenStatic, adLockReadOnly
    If (vRs.EOF) Then
       If (vRs.State = adStateOpen) Then vRs.Close
       '''''''''''''''''''''''''''''''''''''''''''
       txtPurcode.Text = ""
       txtSuppName.Text = ""
       txtPurdate.Text = ""
       txtSuppno.Text = ""
       txtIptno.Text = ""
       txtYWY.Text = ""
       txtDD.Text = ""
       cmbPayType.Text = ""
       grdDET.RemoveAll
       sb1.Panels(1).Text = "无匹配纪录!"
       ''''''''''''''''''''''''''''''''''''''''''
       Exit Sub
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    txtPurcode.Text = vRs("表单号")
    txtDD.Text = vRs("订单号")
    txtGrpno.Text = vRs("经营公司")
    cmbPayType.Text = vRs("付款方式")
    txtPurdate.Text = CStr(Format(vRs("配送日期"), "YYYY-MM-DD"))
    txtSuppno.Text = vRs("分店编码")
    txtYWY.Text = vRs("业务员")
    txtSuppno.DroppedDown = True
    txtSuppno.DroppedDown = False
    txtSuppName.Text = vRs("分店名称")
    sSQL = " select * from 分店主档 where  分店编码='" & vRs("分店编码") & "' "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
'    txtSuppName.Text = vRs(1)
    txtIptno.Text = vRs("录入员")
    
    If Trim(vRs("备注")) <> "0" Then txtRemark.Text = vRs("备注") Else txtRemark.Text = ""
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '如果确认状态为真则不允许修改
    If vRs("确认状态") Then
        cmdToolCommit.Caption = "弃审[&O]"
        cmdSave.Enabled = False
        cmdDelete.Enabled = False
        grdDET.AllowUpdate = False
        grdDET.SelectByCell = True
    Else
        cmdToolCommit.Caption = "审核[&O]"
        cmdSave.Enabled = True
        cmdDelete.Enabled = True
        grdDET.AllowUpdate = True
        grdDET.SelectByCell = False
    End If
    grdDET.RemoveAll
    While Not vRs.EOF
        Temp = vRs("商品编码") & vbTab & vRs("品名") & vbTab & Trim(vRs("单位")) & _
              vbTab & Trim(vRs("颜色")) & _
              vbTab & Trim(vRs("尺寸")) & _
              vbTab & Trim(vRs("进价")) & _
              vbTab & Trim(vRs("加点")) & _
              vbTab & vRs("零售价") & _
              vbTab & vRs("配送数量") & vbTab & vRs("售价金额")
        grdDET.AddItem Temp
        '记录后移
        vRs.MoveNext
    Wend
    Call ShowPosition
    Call CalTotalDelete
    Exit Sub
MyErr:
    ErrNum = Err.number
    MsgBox "读数据库发生错误!" & vbCrLf & Error$(ErrNum), vbExclamation, "错误窗口"
End Sub

'保存表
Private Function SaveTable() As Boolean
    On Error GoTo SaveErr
    Dim I As Integer
    Dim sSQL As String
    grdDET.MoveFirst
    For I = 0 To grdDET.Rows - 1
        sSQL = "INSERT INTO  " & TableName & " (表单号,订单号,经营公司,配送日期,分店编码," & _
            "分店名称,业务员,录入员,商品编码,品名,单位,颜色,尺寸,进价,加点,配送数量," & _
            "零售价,售价金额,确认状态,备注,付款方式)" & _
            " VALUES('"
        sSQL = sSQL & _
            Trim(txtPurcode.Text) & "','" & _
            Trim(txtDD.Text) & "','" & _
            Trim(txtGrpno.Text) & "','" & _
            Trim(txtPurdate.Text) & "','" & _
            Trim(txtSuppno.Text) & "','" & _
            Trim(txtSuppName.Text) & "','" & _
            Trim(txtYWY.Text) & "','" & _
            Trim(txtIptno.Text) & "','"
        sSQL = sSQL & _
            Trim(grdDET.Columns("商品编码").Text) & "','" & _
            Trim(grdDET.Columns("商品名称").Text) & "','" & _
            Trim(grdDET.Columns("单位").Text) & "','" & _
            Trim(grdDET.Columns("颜色").Text) & "','" & _
            Trim(grdDET.Columns("尺寸").Text) & "'," & _
            Val(grdDET.Columns("进价").Value) & "," & _
            Val(grdDET.Columns("加点").Value) & "," & _
            Val(grdDET.Columns("数量").Value) & "," & _
            Val(grdDET.Columns("单价").Value) & "," & _
            Val(grdDET.Columns("金额").Value) & ",0,'" & _
            Trim(txtRemark.Text) & "','" & Trim(cmbPayType.Text) & "')"
        Cmd.CommandText = sSQL
        Cmd.Execute
        grdDET.MoveNext
    Next I
    SaveTable = True
    Exit Function
SaveErr:
    ErrNum = Err.number
    MsgBox "保存数据库发生错误!", vbExclamation, "提示窗口"
End Function

Private Sub cmdNew_Click()
    On Error Resume Next
    Dim sSQL As String
    '清表
    RefreshTable (" ")
    If GetSetting("LSDSTAR", "进销管理", "配送单单号是否自动生成", "1") = "1" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If    '确认，保存，删除
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    cmdToolCommit.Caption = "审核[&O]"
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    cmdPrev.Enabled = False
    cmdNext.Enabled = False
    cmdDelete.Enabled = True
    '提示
    sb1.Panels(1).Text = "请输入新表单"
    txtRemark.Text = ""
    
    GCount = 0
    TableState = "新建"
    grdDET.AllowUpdate = True
    grdDET.SelectByCell = False
    QueryFlag = False
    txtIptno.Text = UserCode
    txtYWY.Text = ""
    If GetSetting("LSDSTAR", "库存设置", "配送单自动保存", "1") = "1" Then
        sSQL = "INSERT INTO  " & TableName & " (表单号) VALUES('" & Trim(txtPurcode.Text) & "')"
        Cmd.ActiveConnection = Conn