frm+

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

        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) & "'"
    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 = ""
       grdDET.RemoveAll
       sb1.Panels(1).Text = "无匹配纪录!"
       ''''''''''''''''''''''''''''''''''''''''''
       Exit Sub
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    txtPurcode.Text = vRs("表单号")
    txtGrpno.Text = vRs("经营公司")
    txtPurdate.Text = CStr(Format(vRs("配送日期"), "YYYY-MM-DD"))
    txtSuppno.Text = vRs("分店编码")
    sSQL = " select * from 分店主档 where  分店编码='" & vRs("分店编码") & "' "
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    txtSuppName.Text = RsTemp(1)
    txtIptno.Text = vRs("录入员")
    
    If Trim(vRs("备注")) <> "0" Then txtRemark.Text = vRs("备注") Else txtRemark.Text = ""
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '如果确认状态为真则不允许修改
    cmdVil.Enabled = Not vRs("确认状态")
    cmdSave.Enabled = Not vRs("确认状态")
    cmdDelete.Enabled = Not vRs("确认状态")
    cmdToolUnCommit.Enabled = vRs("确认状态")
    grdDET.RemoveAll
    While Not vRs.EOF
        Temp = vRs("商品编码") & vbTab & vRs("品名") & vbTab & Trim(vRs("单位")) & _
              vbTab & vRs("配送数量") & _
              vbTab & vRs("零售价") & vbTab & vRs("售价金额") & _
              vbTab & vRs("进价") & vbTab & vRs("进价金额") & vbTab & vRs("含税进价")
        grdDET.AddItem Temp
        '记录后移
        vRs.MoveNext
    Wend
    Call ShowPosition
    Call CalTotal
    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(txtGrpno.Text) & "','" & _
            Trim(txtPurdate.Text) & "','" & _
            Trim(txtSuppno.Text) & "','" & _
            Trim(txtSuppName.Text) & "','" & _
            Trim("1122") & "','" & _
            Trim("1122") & "','" & _
            Trim("1122") & "','" & _
            Trim(txtIptno.Text) & "','"
        sSQL = sSQL & _
            Trim(grdDET.Columns(0).Text) & "','" & _
            Trim(grdDET.Columns(1).Text) & "','" & _
            Trim(grdDET.Columns(2).Text) & "'," & _
            Val(grdDET.Columns(3).Value) & "," & _
            Val(grdDET.Columns(6).Value) & "," & _
            Val(grdDET.Columns(7).Value) & "," & _
            Val(grdDET.Columns(4).Value) & "," & _
            Val(grdDET.Columns(5).Value) & ",0," & _
            Val(grdDET.Columns(8).Value) & ",'" & Trim(txtRemark.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 (" ")
    sSQL = " select max(表单号)+1 from 商品配送单 "
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    If Not IsNull(RsTemp(0)) Then txtPurcode.Text = Format(RsTemp(0), "0000000")
    '确认，保存，删除
    cmdVil.Enabled = False
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    cmdPrev.Enabled = False
    cmdNext.Enabled = False
    cmdToolUnCommit.Enabled = False
    '提示
    sb1.Panels(1).Text = "请输入新表单"

    TableState = "新建"
    grdDET.AllowUpdate = True
    grdDET.SelectByCell = False
    QueryFlag = False
    txtIptno.Text = UserCode
End Sub
Private Function DX(num2 As Integer) As String
    If num2 > 10 Or Len(Trim(Str(num2))) <> 1 Then Exit Function
    If num2 = 1 Then DX = "壹"
    If num2 = 2 Then DX = "贰"
    If num2 = 3 Then DX = "叁"
    If num2 = 4 Then DX = "肆"
    If num2 = 5 Then DX = "伍"
    If num2 = 6 Then DX = "陆"
    If num2 = 7 Then DX = "柒"
    If num2 = 8 Then DX = "捌"
    If num2 = 9 Then DX = "玖"
    If num2 = 0 Then DX = "零"
End Function

Private Function D2X(number As Single) As String
    Dim s As String
    Dim s1 As String
    Dim s2 As String
    Dim num As Single
    num = Abs(number)
    s = Str(num)
    If InStr(1, s, ".") <> 0 Then
       s1 = Mid(s, 1, InStr(1, s, "."))
       s2 = Mid(s, InStr(1, s, ".") + 1)
    Else
       s1 = s
    End If
    num = Val(s1)
    s = "△"
    If num < 100000 Then If num \ 100000 <> 0 Then s = s & DX(num \ 100000) & "拾"
    num = num Mod 100000
    If num \ 10000 <> 0 Then s = s & DX(num \ 10000) & "万"
    num = num Mod 10000
    If num \ 1000 <> 0 Then s = s & DX(num \ 1000) & "仟"
    num = num Mod 1000
    If num \ 100 <> 0 Then s = s & DX(num \ 100) & "佰"
    num = num Mod 100
    s = s & DX(num \ 10) & "拾"
    num = num Mod 10
    s = s & DX(num \ 1) & "圆"
    If s2 <> "" Then
          s = s & DX(Val(Mid(s2, 1, 1))) & "角"
          If Len(s2) >= 2 Then s = s & DX(Mid(s2, 2, 1)) & "分"
    End If
    D2X = s
End Function

Private Sub cmdPrintBill_Click()
    On Error Resume Next
    Dim i, j
    Dim strControl As String, strValue As String
    Load rpt规则进货单
    
    rpt规则进货单.Sections("Indent").Controls("lbltitle").Caption = GetSetting("进销存管理系统", "单据标题", "配送单")
    rpt规则进货单.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
    rpt规则进货单.Sections("Indent").Controls("lblgrp").Caption = "连锁店:" & txtSuppName.Text
    rpt规则进货单.Sections("Indent").Controls("lblDate").Caption = "日期:" & txtPurdate.Text
    If txtRemark.Text <> "" Then rpt规则进货单.Sections("Indent").Controls("lblRemark").Caption = "备注:" & txtRemark.Text
    rpt规则进货单.Sections("Indent").Controls("lblIptno").Caption = "开票:" & txtIptno.TheName
    rpt规则进货单.Sections("Indent").Controls("lblIamt").Caption = txtIamt.Text
    rpt规则进货单.Sections("Indent").Controls("lblsum").Caption = txtIamt0.Text
    rpt规则进货单.Sections("Indent").Controls("lbldx").Caption = D2X(Val(txtIamt.Text))
    grdDET.MoveFirst
    For i = 1 To grdDET.Rows
        For j = 0 To 5
            strControl = "lblc" & (j + 1) & "r" & i
            If j = 4 Or j = 5 Then
               strValue = Format(grdDET.Columns(j).Text, "#.00")
            Else
               strValue = grdDET.Columns(j).Text
            End If
            rpt规则进货单.Sections("Indent").Controls(strControl).Caption = strValue
        Next j
        grdDET.MoveNext
    Next i
    'rpt规则进货单.Show
    rpt规则进货单.PrintReport
    Unload rpt规则进货单
    MsgBox "打印完成!", vbInformation, "提示窗口"
End Sub

Private Sub cmdQuery_Click()
    On Error GoTo MyErr
    If (cmdQuery.Caption = "查询[&Q]") Then
       cmdQuery.Caption = "开始[&Q]"
       Call RefreshTable(" ")
       BeginQuery
       sb1.Panels(1).Text = "请输入查询条件。"
    Else
       CommitQuery
       QueryFlag = False
    End If
    Exit Sub
MyErr:
    MsgBox "查询发生错误." & Chr(13) & "错误信息:" & Err.Description, , "错误窗口"
End Sub

'删除当前表
Private Sub cmdDelete_Click()
    On Error GoTo MyErr
    Dim sSQL As String
    Dim Rs As New ADODB.Recordset
    If txtPurcode.Text = "" Then
       MsgBox "当前表单为空!", vbExclamation, "提示窗口"
       Exit Sub
    End If
    '检查是否存在相同单号的付款单.
    sSQL = "SELECT * FROM " & TableName & " WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Set Rs = Nothing
    Rs.Open sSQL, Conn, adOpenStatic, adLockReadOnly
    '如果存在
    If (Not Rs.EOF) Then
       '数据库中已有此付款单.
       If (Rs("确认状态") = True) Then
          '已经确认不允许修改.
          MsgBox "此配送单已经确认不允许修改", vbExclamation, "提示窗口"
          If (Rs.State = adStateOpen) Then Rs.Close
          Exit Sub
       End If
    End If
    Temp = "您一定要删除表单号为:" & Trim(txtPurcode.Text) & "的配送单吗?"
    If (MsgBox(Temp, vbYesNo + vbDefaultButton2 + vbExclamation) = vbNo) Then
       If (Rs.State = adStateOpen) Then Rs.Close
       Exit Sub
    End If
    '删除
    Cmd.CommandText = "DELETE  FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
    Cmd.Execute
    '确认，删除，前项，后项
    cmdVil.Enabled = False
    cmdDelete.Enabled = False
    cmdPrev.Enabled = False
    cmdNext.Enabled = False
    '清表
    Call RefreshTable("")
    '提示
    sb1.Panels(1).Text = "配送单已被删除。"
    If (Rs.State = adStateOpen) Then Rs.Close
    Exit Sub
MyErr:
    If (Rs.State = adStateOpen) Then Rs.Close
    sb1.Panels(1).Text = "删除配送单失败。"
    MsgBox "删除指配送单时发生错误,信息:" + Err.Description, vbCritical, "错误窗口"
End Sub

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

'下一条记录
Private Sub cmdNext_Click()
    On Error GoTo MyErr:
    If (Not QueryRs.EOF) Then
       QueryRs.MoveNext
       If (Not QueryRs.EOF) Then
          RefreshTable (QueryRs("表单号"))
       Else
          Call RefreshTable(" ")
          sb1.Panels(1).Text = "已经到查询结果末尾了。"
       End If
    End If
    Exit Sub
MyErr:
    MsgBox "在移动到下一表单时发生错误,信息:" + Err.Description, vbCritical
End Sub

'上一条记录
Private Sub cmdPrev_Click()
    On Error GoTo MyErr:
    If (Not QueryRs.BOF) Then
       QueryRs.MovePrevious
       If (Not QueryRs.BOF) Then
          RefreshTable (QueryRs("表单号"))
       Else
          Call RefreshTable(" ")
          sb1.Panels(1).Text = "已经到查询结果开头了。"
       End If
    End If
    Exit Sub
MyErr:
    MsgBox "在移动到上一表单时发生错误,信息:" + Err.Description, vbCritical
End Sub


'保存表
Private Sub cmdSave_Click()
    Dim sSQL As String
    On Error GoTo MyErr
    If Not DataIsOK() Then
        MsgBox "数据存在错误!请检查!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Call CalTotal
    '检查是否存在相同编号供应商编码.
    sSQL = "SELECT * FROM " & TableName & " WHERE 表单号='" & txtPurcode.Text & "'"
    Set RsTemp = Nothing
    Set RsTemp = OpenRS(sSQL)
    '如果存在
    If Not RsTemp.EOF Then
       If (RsTemp("确认状态") = True) Then
          '供应商编码审批表已经确认不允许修改.
          MsgBox "此单据已经确认不允许修改", vbExclamation, "提示窗口"
          Exit Sub
       Else
          '表未确认,允许修改.
          Temp = "此操作将覆盖原来数据,您确认要继续吗?"
          If (MsgBox(Temp, vbYesNo + vbDefaultButton2 + vbQuestion) = vbNo) Then Exit Sub
       End If