bascomm.bas

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

End Function

'获取服务器系统时间
Public Function GetDate() As String
On Error GoTo MyErr:
    Set RsTemp = Nothing
    RsTemp.Open "SELECT GETDATE() AS NOWTIME", Conn, adOpenStatic, adLockReadOnly
    GetDate = Format(RsTemp("NOWTIME"), "YYYY-MM-DD 00:00:SS")
    Exit Function
MyErr:
    MsgBox "读取服务器系统时间发生错误，信息：" + Err.Description
End Function

Public Function WriteLog(LogType As String, Log As String) As Boolean
    Dim sSQL As String
    On Error GoTo RemovErr
    sSQL = "INSERT INTO SYSLOG(OPERATOR,TERMINAL,SYSTIME,OPERATIONTYPE,DESCRIPTION,UNITCODE)" & _
        " VALUES('" & UserCode & "','" & TerminalName & "','" & GetDate & "','" & LogType & "','" & Log & "','" & SysUnit & "')"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    WriteLog = True
    Set Cmd = Nothing
    Exit Function
RemovErr:
    MsgBox "记录写入失败！", vbExclamation, "错误窗口"
    WriteLog = False
End Function


Public Function OutStock(GCode As String, GName As String, Unit As String, Color As String, Size As String, Qty As Single) As Boolean
    Dim RsTemp As New ADODB.Recordset
    Dim R As New ADODB.Recordset
    Dim Iprc, IIprc, Rprc, Qtyt
    On Error GoTo CommitErr
    
    GCode = Trim(GCode)
    GName = Trim(GName)
    Unit = Trim(Unit)
    Color = Trim(Color)
    Size = Trim(Size)
    
    Cmd.ActiveConnection = Conn
    sSQL = "SELECT 商品编码,进价,含税进价,零售价 FROM 商品主档 WHERE 商品编码='" & GCode & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    Iprc = RsTemp("进价")
    IIprc = RsTemp("含税进价")
    Rprc = RsTemp("零售价")
    
    sSQL = "SELECT * FROM 配送中心库存 WHERE  商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If GetSetting("LSDSTAR", "库存设置", "允许负库存销售", "1") <> "1" Then
        If RsTemp.EOF Then
            Qtyt = 0
        Else
            Qtyt = RsTemp("数量")
        End If
        If -Qty > Qtyt Then
            MsgBox "库存数量不足！" & "商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "'", vbExclamation, "提示窗口"
            OutStock = False
            Exit Function
        End If
    End If
    
    If RsTemp.EOF Then
        RsTemp.AddNew
        RsTemp("商品编码") = GCode
        RsTemp("品名") = GName
        RsTemp("单位") = Unit
        RsTemp("颜色") = Color
        RsTemp("尺寸") = Size
        RsTemp("数量") = Qty
        RsTemp("进价金额") = Qty * Iprc
        RsTemp("含税进价金额") = Qty * IIprc
        RsTemp.Update
     '存在,对库存进行更新
    Else
        RsTemp("数量") = RsTemp("数量") + Qty
        RsTemp("进价金额") = RsTemp("进价金额") + Qty * Iprc
        RsTemp("含税进价金额") = RsTemp("含税进价金额") + Qty * IIprc
        RsTemp.Update
    End If
    
    sSQL = "SELECT 商品编码,sum(进价金额) as 进价金额,sum(含税进价金额) as 含税进价金额,sum(数量) as 数量 FROM 配送中心库存 WHERE  商品编码='" & GCode & "' group by 商品编码"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp("数量") <> 0 Then
        sSQL = "UPDATE 商品主档 SET 进价=" & Format(RsTemp("进价金额") / RsTemp("数量"), DecNum) & ",含税进价=" & Format(RsTemp("含税进价金额") / RsTemp("数量"), DecNum) & _
           " WHERE 商品编码='" & GCode & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        Cmd.Execute
    End If

    OutStock = True
    Exit Function
CommitErr:
    MsgBox "确认失败!,请检查数据是否存在错误!" & vbCrLf & Err.Description, vbExclamation, "警告窗口"
    OutStock = False
End Function


Public Function InSubStock(SubStock As String, GCode As String, GName As String, Unit As String, Color As String, Size As String, Qty As Single, prc As Single, sprc As Single) As Boolean
    Dim RsTemp As New ADODB.Recordset
    Dim R As New ADODB.Recordset
    On Error GoTo CommitErr
    
    SubStock = Trim(SubStock)
    GCode = Trim(GCode)
    GName = Trim(GName)
    Unit = Trim(Unit)
    Color = Trim(Color)
    Size = Trim(Size)
    
    Cmd.ActiveConnection = Conn
    
    sSQL = "SELECT * FROM 分店库存 WHERE 分店编码='" & SubStock & "' and  商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
       RsTemp.AddNew
       RsTemp("分店编码") = SubStock
        RsTemp("商品编码") = GCode
        RsTemp("品名") = GName
        RsTemp("单位") = Unit
        RsTemp("颜色") = Color
        RsTemp("尺寸") = Size
        RsTemp("数量") = Qty
        RsTemp("进价金额") = Qty * prc
        RsTemp.Update
    Else
       RsTemp("数量") = RsTemp("数量") + Qty
       RsTemp("进价金额") = RsTemp("进价金额") + Qty * prc
       RsTemp.Update
    End If
    

    InSubStock = True
    Exit Function
CommitErr:
    MsgBox "确认失败!,请检查数据是否存在错误!" & vbCrLf & Err.Description, vbExclamation, "警告窗口"
    InSubStock = False
End Function

Public Function OutSubStock(SubStock As String, GCode As String, GName As String, Unit As String, Color As String, Size As String, Qty As Single) As Boolean
    Dim RsTemp As New ADODB.Recordset
    Dim R As New ADODB.Recordset
    Dim prc As Single
    On Error GoTo CommitErr
    
    
    SubStock = Trim(SubStock)
    GCode = Trim(GCode)
    GName = Trim(GName)
    Unit = Trim(Unit)
    Color = Trim(Color)
    Size = Trim(Size)
    
    Cmd.ActiveConnection = Conn
    
    sSQL = "SELECT sum(进价金额)/sum(数量) as 配送价 FROM 分店库存 WHERE 分店编码='" & SubStock & _
        "' and  商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "' group by 商品编码 having sum(数量)<>0"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    If RsTemp.EOF Then
        prc = 0
    Else
        prc = RsTemp("配送价")
    End If
    
    sSQL = "SELECT * FROM 分店库存 WHERE 分店编码='" & SubStock & "' and  商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
       RsTemp.AddNew
       RsTemp("分店编码") = SubStock
        RsTemp("商品编码") = GCode
        RsTemp("品名") = GName
        RsTemp("单位") = Unit
        RsTemp("颜色") = Color
        RsTemp("尺寸") = Size
        RsTemp("数量") = Qty
        RsTemp("进价金额") = Qty * prc
        RsTemp.Update
    Else
       RsTemp("数量") = RsTemp("数量") + Qty
       RsTemp("进价金额") = RsTemp("进价金额") + Qty * prc
       RsTemp.Update
    End If
    
    OutSubStock = True
    Exit Function
CommitErr:
    MsgBox "确认失败!,请检查数据是否存在错误!" & vbCrLf & Err.Description, vbExclamation, "警告窗口"
    OutSubStock = False
End Function

Public Function InStock(GCode As String, GName As String, Unit As String, Color As String, Size As String, Qty As Single, prc As Single, TaxPrc As Single) As Boolean
    Dim RsTemp As New ADODB.Recordset
    Dim R As New ADODB.Recordset
    On Error GoTo CommitErr
    
    GCode = Trim(GCode)
    GName = Trim(GName)
    Unit = Trim(Unit)
    Color = Trim(Color)
    Size = Trim(Size)
    
    Cmd.ActiveConnection = Conn
    
    sSQL = "SELECT * FROM 配送中心库存 WHERE  商品编码='" & GCode & "' and 颜色='" & Color & "' and 尺寸='" & Size & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
  
    If RsTemp.EOF Then
        RsTemp.AddNew
        RsTemp("商品编码") = GCode
        RsTemp("品名") = GName
        RsTemp("单位") = Unit
        RsTemp("颜色") = Color
        RsTemp("尺寸") = Size
        RsTemp("数量") = Qty
        RsTemp("进价金额") = Qty * prc
        RsTemp("含税进价金额") = Qty * TaxPrc
        RsTemp.Update
     '存在,对库存进行更新
    Else
        RsTemp("数量") = RsTemp("数量") + Qty
        RsTemp("进价金额") = RsTemp("进价金额") + Qty * prc
        RsTemp("含税进价金额") = RsTemp("含税进价金额") + Qty * TaxPrc
        RsTemp.Update
    End If
    
    sSQL = "SELECT 商品编码,sum(进价金额) as 进价金额,sum(含税进价金额) as 含税进价金额,sum(数量) as 数量 FROM 配送中心库存 WHERE  商品编码='" & GCode & "' group by 商品编码"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp("数量") <> 0 Then
        sSQL = "UPDATE 商品主档 SET 进价=" & Format(RsTemp("进价金额") / RsTemp("数量"), DecNum) & ",含税进价=" & Format(RsTemp("含税进价金额") / RsTemp("数量"), DecNum) & _
           " WHERE 商品编码='" & GCode & "'"
        Cmd.ActiveConnection = Conn
        Cmd.CommandText = sSQL
        Cmd.Execute
    End If


    InStock = True
    Exit Function
CommitErr:
    MsgBox "确认失败!,请检查数据是否存在错误!" & vbCrLf & Err.Description, vbExclamation, "警告窗口"
    InStock = False
End Function