frm+

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

    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()
    '清空表头
    txtPurcode.Text = ""
    txtPurdate.Text = ""        'CStr(Now)
    cmbClient.Text = ""
    txtIptno.Text = ""
    
    txtRamt.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("表单号")
    cmbClient.Text = vRs("客户")
    txtPurdate.Text = CStr(Format(vRs("制表日期"), "YYYY-MM-DD"))
    txtIptno.Text = vRs("录入员")
    
    '如果确认状态为真则不允许修改
    If vRs("确认状态").Value Then
        cmdToolCommit.Enabled = False
        cmdToolDelete.Enabled = False
        cmdToolSave.Enabled = False
        grdDET.AllowUpdate = False
    Else
        cmdToolCommit.Enabled = True
        cmdToolDelete.Enabled = True
        cmdToolSave.Enabled = True
        grdDET.AllowUpdate = True
    End If
    
    While Not vRs.EOF
        grdDET.AddItem Trim(vRs("商品编码")) & vbTab & _
                    Trim(vRs("品名")) & vbTab & _
                    Trim(vRs("单位")) & vbTab & _
                    Str(vRs("数量")) & vbTab & _
                    Str(vRs("原进价")) & vbTab & _
                    Str(vRs("现进价")) & vbTab & _
                    Str(vRs("批发价")) & vbTab & _
                    Str(vRs("售价差额"))
        '记录后移
        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 TransErr
    Dim N
    grdDET.Update
    '增加记录
    grdDET.MoveFirst
    For N = 0 To grdDET.Rows - 1
    sSQL = "INSERT INTO 批发单" & _
            "(表单号,制表日期,客户,审核员,部门经理,录入员," & _
            "商品编码,品名,单位,数量,原进价,现进价,批发价,售价差额)VALUES('" & _
            Trim(txtPurcode.Text) & "','" & _
            Trim(txtPurdate.Text) & "','" & _
            Trim(cmbClient.Text) & "','" & _
            "00000" & "','" & _
            "00000" & "','" & _
            Trim(txtIptno.Text) & "','" & _
            grdDET.Columns("商品编码").Value & "','" & _
            grdDET.Columns("品名").Value & "','" & _
            grdDET.Columns("单位").Value & "'," & _
            Str(grdDET.Columns("数量").Value) & "," & _
            Str(grdDET.Columns("参考进价").Value) & "," & _
            Str(grdDET.Columns("扣率").Value) & "," & _
            Str(grdDET.Columns("售价").Value) & "," & _
            Str(grdDET.Columns("金额").Value) & ")"
           
        If RunSQL(sSQL) <> 0 Then
            MsgBox "明细更新失败!" & vbCrLf & Error$(ErrNum), vbExclamation, "警告窗口"
            SaveTable = False
            Exit Function
        End If
        grdDET.MoveNext
    Next N
    SaveTable = True
    Exit Function
TransErr:       '错误处理
    SaveTable = False
    ErrNum = Err.number
End Function



Private Sub cmbClient_InitColumnProps()
    On Error Resume Next
    sSQL = "SELECT CLIENTNAME FROM CLIENT"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    While Not RsTemp.EOF
        cmbClient.AddItem Trim(RsTemp("CLIENTNAME"))
        RsTemp.MoveNext
    Wend
End Sub

Private Sub cmbClient_Validate(Cancel As Boolean)
    On Error GoTo AddErr
    sSQL = "SELECT CLIENTNAME FROM CLIENT WHERE CLIENTNAME='" & Trim(cmbClient.Text) & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    If RsTemp.EOF Then
        If MsgBox("无该客户的记录，增加吗？", vbQuestion + vbYesNo, "提示窗口") = vbNo Then
            Cancel = False
            Exit Sub
        Else
            sSQL = "INSERT INTO CLIENT(CLIENTNAME) VALUES('" & Trim(cmbClient.Text) & "')"
            Cmd.ActiveConnection = Conn
            Cmd.CommandText = sSQL
            Cmd.Execute
            cmbClient.AddItem Trim(cmbClient.Text)
            Cancel = False
        End If
    End If
    Exit Sub
AddErr:
    MsgBox "增加客户失败 ！", vbExclamation, "错误窗口"
End Sub


Private Sub cmdPrintBill_Click()
    On Error Resume Next
    Dim N
    Dim strControl As String, strValue As String
    Call CalTotalDelete
    Load rpt规则进货单
    rpt规则进货单.Sections("Indent").Controls("lbltitle").Caption = GetSetting("进销存管理系统", "单据标题", "销售单", "销售单")
    rpt规则进货单.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
    rpt规则进货单.Sections("Indent").Controls("lblgrp").Caption = "收货单位:" & cmbClient.Text
    rpt规则进货单.Sections("Indent").Controls("lblDate").Caption = "日期:" & txtPurdate.Text
    rpt规则进货单.Sections("Indent").Controls("lblYW").Caption = "收货人:"
    rpt规则进货单.Sections("Indent").Controls("lblYH").Visible = False
    rpt规则进货单.Sections("Indent").Controls("lblIptno").Caption = "开票:" & txtIptno.TheName
    rpt规则进货单.Sections("Indent").Controls("lblIamt").Caption = txtRamt.Text
    rpt规则进货单.Sections("Indent").Controls("lbl大写").Caption = D2X(Val(txtRamt.Text))
    rpt规则进货单.Sections("Indent").Controls("lblSJ").Caption = Format(Val(txtRamt.Text) * 0.17 / 1.17, "#.00")
    grdDET.MoveFirst
    For N = 1 To grdDET.Rows
        For j = 0 To 7
            
            If j = 6 Or j = 7 Then
                strControl = "lblc" & (j - 1) & "r" & N
                strValue = Format(grdDET.Columns(j).Text, DecNum)
            ElseIf j = 0 Or j = 1 Or j = 2 Or j = 3 Then
                strControl = "lblc" & (j + 1) & "r" & N
                strValue = grdDET.Columns(j).Text
            End If
            rpt规则进货单.Sections("Indent").Controls(strControl).Caption = strValue
        Next j
        grdDET.MoveNext
    Next N
    'rpt规则进货单.Show
    rpt规则进货单.PrintReport
    Unload rpt规则进货单
    MsgBox "打印完成!", vbInformation, "提示窗口"
End Sub

'增加新表
Private Sub cmdToolAdd_Click()
    On Error Resume Next
    TableState = "新建"
    grdDET.AllowUpdate = True
    Set Rs = Nothing
    QueryFlag = False
    Call ShowStatus(2)
    '清除整个表显示
    Call ClearTable
    
    txtIptno.Text = UserCode
    If GetSetting("进销存管理系统", "进销管理", "销售单单号是否自动生成", "1") = "1" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    cmdToolSave.Enabled = True
    cmdToolCommit.Enabled = False
    cmdToolPrevious.Enabled = False
    cmdToolNext.Enabled = False
    cmdToolDelete.Enabled = False
    txtPurcode.SetFocus
End Sub

'改变确认状态
'只有审核员才能进行该操作
Private Sub cmdToolCommit_Click()
    On Error GoTo ComErr
    If txtPurcode.Text = "" Then
        MsgBox "表单号不能为空!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Temp = "确认之后将不能再作改动,继续吗?"
    Temp = MsgBox(Temp, vbQuestion + vbYesNo, "提示窗口")
    If Temp = vbYes Then
        If Not CommSaveTable() Then
            MsgBox "保存数据时发生错误!", vbExclamation, "错误窗口"
            Exit Sub
        End If
        Call Oper批发
    Else
        Exit Sub
    End If
    Exit Sub
ComErr:
    ErrNum = Err.number
    MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(ErrNum), vbExclamation, "提示窗口"
End Sub

'删除当前表
Private Sub cmdToolDelete_Click()
    On Error Resume Next
    Call ShowStatus(88)
    If txtPurcode.Text = "" Then
        MsgBox "当前表单为空!", vbExclamation, "提示窗口"
        Exit Sub
    End If

    Temp = "确认之要删除该表吗?" & vbCrLf & "表单号为：" & txtPurcode.Text
    Temp = MsgBox(Temp, vbQuestion + vbYesNo, "提示窗口")
    If Temp = vbYes Then
        
        sSQL = "DELETE  FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
        RunSQL sSQL
        
        Call ClearTable
        cmdToolPrevious.Enabled = False
        cmdToolNext.Enabled = False
        Call ShowStatus(5)
    End If
End Sub

'退出
Private Sub cmdToolExit_Click()
    Unload Me
End Sub

''设置是否进行合法性验证
Private Sub SetValidate(Flag As Boolean)
    txtPurcode.CausesValidation = Flag
    txtPurdate.CausesValidation = Flag
    cmbClient.CausesValidation = Flag
    txtIptno.Validation = Flag
    grdDET.CausesValidation = Flag
End Sub

'生成查询条件
Private Function GenerateQuerySQL() As String
    Dim strTemp As String
    sSQL = "SELECT 表单号 FROM 批发单 "
    If txtPurcode.Text <> "" Then
        strTemp = strTemp & "  表单号" & AnalyseCondition(txtPurcode.Text, True) & " AND "
    End If
    If txtPurdate.Text <> "" Then
        strTemp = strTemp & "  制表日期 BETWEEN '" & _
                Format(txtPurdate.Text, "YYYY-MM-DD 00:00") & "' AND '" & _
                Format(txtPurdate.Text, "YYYY-MM-DD") & " 23:59' AND "
    End If
    If cmbClient.Text <> "" Then
        strTemp = strTemp & "  客户" & _
            AnalyseCondition(cmbClient.Text, True) & " AND "
    End If
    If txtIptno.Text <> "" Then
        strTemp = strTemp & "  录入员" & _
            AnalyseCondition(txtIptno.Text, True) & " AND "
    End If
    If grdDET.Columns(0).CellText(0) <> "" Then
        strTemp = strTemp & "  商品编码 " & _
            AnalyseCondition(grdDET.Columns(0).CellText(0), True) & " AND "
    End If

     strTemp = strTemp & "  数量 > 0 AND "
    If strTemp <> "" Then
        '去掉尾部的" AND "
        sSQL = sSQL & " WHERE " & Mid(strTemp, 1, Len(strTemp) - 4)
    End If
    sSQL = sSQL & " GROUP BY 表单号,制表日期 ORDER BY 制表日期 desc,表单号 desc"
    GenerateQuerySQL = sSQL
End Function

'查询
Private Sub cmdToolQuery_Click()
    Dim strTemp As String
    TableState = "查询"