frmjhd.frm

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

            Qty = -grdDET.Columns("数量").Value
        End If
        
        sSQL = "update lsdhd set 已售数量=已售数量+(" & Qty & ") where 表单号='" & Trim(txtDDH.Text) & "' and 商品编码='" & _
            Trim(grdDET.Columns("商品编码").Text) & "' and 颜色='" & Trim(grdDET.Columns("颜色").Text) & "' and 尺寸='" & _
            Trim(grdDET.Columns("尺寸").Text) & "'"
        Cmd.CommandText = sSQL
        Cmd.Execute
        grdDET.MoveNext
    Next I
End Function

Private Sub SetButtonState(d As Boolean)
    If d Then
        cmdToolCommit.Caption = "弃审[&O]"
        cmdToolSave.Enabled = False
        cmdToolDelete.Enabled = False
        grdDET.AllowUpdate = False
        grdDET.SelectByCell = True
    Else
        cmdToolCommit.Caption = "审核[&O]"
        cmdToolSave.Enabled = True
        cmdToolDelete.Enabled = True
        grdDET.AllowUpdate = True
        grdDET.SelectByCell = False
    End If
End Sub

Private Function AcceptVil(d As Boolean) As Boolean
    On Error GoTo ComErr
    Dim N
    Dim RsStore As New ADODB.Recordset
    Dim RsS As New ADODB.Recordset
    Dim IIprc, IIIprc, Qty As Single, sum, ssum
    

    If Not CommSaveTable() Then
        MsgBox "保存数据时发生错误!", vbExclamation, "错误窗口"
        Exit Function
    End If
    
    Conn.BeginTrans
    If d Then
        sSQL = "UPDATE LSJHD SET 确认状态=1 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Else
        sSQL = "UPDATE LSJHD SET 确认状态=0 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    End If
    If RunSQL(sSQL) <> 0 Then
        MsgBox "确认失败!,请检查数据是否正确!", vbExclamation, "提示窗口"
        Conn.RollbackTrans
        Exit Function
    End If

    sSQL = "select 商品编码,品名,单位,颜色,尺寸,进货数量 as 数量,含税进价 as 含税单价,进价 as 不含税单价 from lsjhd where 表单号='" & Trim(txtPurcode.Text) & "'"
    Set RsS = Nothing
    RsS.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    
    While Not RsS.EOF
'        grdDET.Row = N
        If d Then
            Qty = RsS("数量")
        Else
            Qty = -RsS("数量")
        End If
        
        If Not InStock(RsS("商品编码"), RsS("品名"), _
              RsS("单位"), RsS("颜色"), RsS("尺寸"), _
               Qty, RsS("不含税单价"), RsS("含税单价")) Then
            MsgBox "确认失败!,请检查数据是否正确!", vbInformation, "提示窗口"
            Conn.RollbackTrans
            Exit Function
        End If
        RsS.MoveNext
    Wend


     '接受事务
    If Rs.State = adStateClosed Then
        cmdToolPrevious.Enabled = False
        cmdToolNext.Enabled = False
    Else
        Rs.Requery
        Rs.Find "表单号='" & Trim(txtPurcode.Text) & "'"
    End If
        
    Call SetButtonState(d)
        
    If GetSetting("LSDSTAR", "库存设置", "显示订单", "1") = "1" Then
       Call VilDD(d)
    End If

    
    Conn.CommitTrans
    Exit Function
ComErr:
    ErrNum = Err.number
    MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"
    Conn.RollbackTrans

End Function

Private Function CommSaveTable() As Boolean
    On Error GoTo CommSaveErr
    sSQL = "DELETE FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    If SaveTable() Then
        CommSaveTable = True
        Exit Function
    Else
        CommSaveTable = False
        Exit Function
    End If
CommSaveErr:
    CommSaveTable = False
End Function



'
'检查数据是否合法
'
Private Function DataOK() As Boolean
    If Trim(txtPurcode.Text) = "" Then
        DataOK = False
        Exit Function
    End If
    If Trim(txtPurdate.Text) = "" Then
        DataOK = False
        Exit Function
    End If
    If Trim(cmbProvider.Text) = "" Then
        DataOK = False
        Exit Function
    End If
    If Trim(txtIptno.Text) = "" Then
        DataOK = False
        Exit Function
    End If
    If grdDET.Rows = 0 Then
        DataOK = False
        Exit Function
    End If
    DataOK = True
End Function


'在状态条上显示记录信息和状态信息

Private Sub ShowStatus(Flag As Integer)
    Select Case Flag
        Case 0      '查询记录移动
            If Rs.EOF Then
                Temp = "已经移到记录末尾了"
            ElseIf Rs.BOF Then
                Temp = "已经移到记录开始"
            Else
                Temp = "第" & Rs.AbsolutePosition & "条"
            End If
            stbData.Panels("状态信息").Text = "总共:" & Rs.RecordCount & _
                "条之第: " & Temp
        Case 1      '开始查询
            stbData.Panels("状态信息").Text = "请输入查询条件:"
        Case 2      '请输入新表单
            stbData.Panels("状态信息").Text = "请输入新表单:"
        Case 3      '保存表单
            stbData.Panels("状态信息").Text = "表单保存完毕"
        Case 4      '保存表单
            stbData.Panels("状态信息").Text = "该表单已经确认"
        Case 5
            stbData.Panels("状态信息").Text = "该表单已经删除 "
        Case Else
            stbData.Panels("状态信息").Text = ""
    End Select
End Sub


'将表的表头和明细清空
Private Sub ClearTable()
    '清空表头
    txtDDH.Text = ""
    txtPurcode.Text = ""
    txtPurdate.Text = ""
    cmbProvider.Text = ""
    TxtName.Text = ""
    txtIptno.Text = ""
    txtIamt.Text = ""
    txtQty.Text = ""
    txtIamt0.Text = ""
    txtRemark.Text = ""
    

    '清空明细
    grdDET.Update
    grdDET.RemoveAll
End Sub

'刷新表显示

Private Sub RefreshTable(vRs As ADODB.Recordset)
    On Error GoTo RefErr
    If vRs.EOF Or vRs.BOF Then Exit Sub
    grdDET.Update
    grdDET.RemoveAll
    '表头文本框刷新
    txtPurcode.Text = vRs("表单号")
    txtDDH.Text = vRs("订单号")
    txtPurdate.Text = CStr(Format(vRs("制表日期"), "YYYY-MM-DD 00:00"))
    cmbProvider.Text = vRs("厂商编码")
    cmbProvider.DroppedDown = True
    cmbProvider.DroppedDown = False
    TxtName.Text = cmbProvider.Columns(1).Text
    txtIptno.Text = vRs("录入员")
    
    If Trim(vRs("备注")) <> "0" Then txtRemark.Text = vRs("备注") Else txtRemark.Text = ""
    
    
    '如果确认状态为真则不允许修改
    If vRs("确认状态").Value Then
        cmdToolCommit.Caption = "弃审[&O]"
        cmdToolDelete.Enabled = False
        cmdToolSave.Enabled = False
        grdDET.AllowUpdate = False
        grdDET.SelectByCell = True
    Else
        cmdToolCommit.Caption = "审核[&O]"
        cmdToolDelete.Enabled = True
        cmdToolSave.Enabled = True
        grdDET.AllowUpdate = True
        grdDET.SelectByCell = False
    End If
    
    While Not vRs.EOF
       
        Temp = vRs("商品编码") & vbTab & _
                vRs("品名") & vbTab & _
                vRs("单位") & vbTab & _
                vRs("颜色") & vbTab & _
                vRs("尺寸") & vbTab & _
                vRs("含税进价") & vbTab & _
                vRs("进价") & vbTab & _
                vRs("税率") & vbTab & _
                vRs("进货数量") & vbTab & _
                vRs("含税进价金额") & vbTab & _
                vRs("进价金额")
        grdDET.AddItem Temp
        '记录后移
        vRs.MoveNext
    Wend
    Call CalTotalDelete
    Exit Sub
RefErr:
    ErrNum = Err.number
    MsgBox "读数据库发生错误!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"

End Sub

'保存表
Private Function SaveTable() As Boolean
    On Error GoTo SaveErr
    Dim N
    grdDET.MoveFirst
    For N = 0 To grdDET.Rows - 1
        sSQL = "INSERT INTO  " & TableName & " (表单号,订单号,制表日期,厂商编码" & _
            ",录入员,商品编码,品名,单位,颜色,尺寸,进价" & _
            ",进货数量,有效数量,进价金额,税率,含税进价,含税进价金额,备注)" & _
            " VALUES('"
        sSQL = sSQL & _
            Trim(txtPurcode.Text) & "','" & _
            Trim(txtDDH.Text) & "','" & _
            Trim(txtPurdate.Text) & "','" & _
            Trim(cmbProvider.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) & "," & _
            Val(grdDET.Columns("含税进价").Value) & "," & _
            Val(grdDET.Columns("含税进价金额").Value) & ",'" & _
            Trim(txtRemark.Text) & "')"
    
            
        If RunSQL(sSQL) <> 0 Then
            SaveTable = False
            Exit Function
        End If
        grdDET.MoveNext
    Next N
    SaveTable = True
    Exit Function
SaveErr:
    ErrNum = Err.number
    MsgBox "保存数据库发生错误!", vbExclamation, "提示窗口"
End Function


Private Sub cmbProvider_CloseUp()
    TxtName.Text = cmbProvider.Columns(1).Text
End Sub

Private Sub cmbProvider_GotFocus()
    cmbProvider.DroppedDown = True
End Sub


Private Sub cmbProvider_InitColumnProps()
    On Error GoTo LinkErr
    Set RsTemp = Nothing
    sSQL = "SELECT 厂商编码,厂商名称 FROM 厂商主档"
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        cmbProvider.AddItem RsTemp("厂商编码") + vbTab + RsTemp("厂商名称")
        RsTemp.MoveNext
    Wend
    Exit Sub
LinkErr:
    MsgBox "初始化数据错误！" & Err.Description, vbExclamation, "错误窗口"
End Sub

Private Sub cmdPrintBill_Click()
    On Error Resume Next
    Dim N, Qty, sum As Single, CurPage, ColorAndSize, PRECOLOR
    Dim strControl As String, strValue As String
    Dim RP As New ADODB.Recordset
    Call CalTotalDelete
    If GetSetting("LSDSTAR", "库存设置", "进货打印含税价", "1") = "1" Then
        sSQL = "select 商品编码,品名,单位,sum(进货数量) as 数量,含税进价 as 单价,sum(含税进价金额) as 金额 from lsjhd   where 表单号='" & Trim(txtPurcode.Text) & "' group by 商品编码,品名,单位,含税进价"
    Else
        sSQL = "select 商品编码,品名,单位,sum(进货数量) as 数量,进价 as 单价,sum(进价金额) as 金额 from lsjhd   where 表单号='" & Trim(txtPurcode.Text) & "' group by 商品编码,品名,单位,进价"
    End If
    Set RsTemp = Nothing
    RsTemp.CursorLocation = adUseClient
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockPessimistic
    
   ' If GetSetting("LSDSTAR", "库存设置", "打印零售价", "1") = "0" Then
    ColorAndSize = ""
    While Not RsTemp.EOF
        Load rptBill
        ColorAndSize = ""
        sum = 0
        Qty = 0
        For N = 0 To 5
            If RsTemp.EOF Then Exit For
            For j = 0 To 5
                If j = 3 Or j = 4 Or j = 5 Then
                    strControl = "lblc" & (j + 1) & "r" & N + 1
                    If j = 3 Then