frmlspsd.frm

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

        Cmd.CommandText = sSQL
        Cmd.Execute
    End If
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 N, j, Qty, sum As Single, CurPage
    Dim strControl As String, strValue As String
    Dim RP As New ADODB.Recordset
    Dim RR As New ADODB.Recordset
    Dim PRECOLOR, ColorAndSize
    sSQL = "select 商品编码,品名,单位,sum(配送数量) as 数量,零售价 as 单价,sum(售价金额) as 金额 from psd  where 表单号='" & Trim(txtPurcode.Text) & "' group by 商品编码,品名,单位,零售价 order by 商品编码"
    Set RsTemp = Nothing
    RsTemp.CursorLocation = adUseClient
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockPessimistic
    
    If GetSetting("LSDSTAR", "库存设置", "打印零售价", "1") = 1 Then
        Call PrintLSJ
    ElseIf GetSetting("LSDSTAR", "库存设置", "打印税金", "1") = 1 Then
        Call PrintSJ
    Else
'        Load rptBill
        ColorAndSize = ""
        While Not RsTemp.EOF
            Load rptBill
            sum = 0
            Qty = 0
            ColorAndSize = ""
            For N = 0 To 5
                If RsTemp.EOF Then Exit For
                
                For j = 0 To 5
                    strControl = "lblc" & (j + 1) & "r" & N + 1
                    If j = 3 Or j = 4 Or j = 5 Then
                        If j = 3 Then
                            strValue = Format(RsTemp(j), "#")
                        Else
                            strValue = Format(RsTemp(j), DecNum)
                        End If
                    ElseIf j = 0 Or j = 1 Or j = 2 Then
                        strValue = RsTemp(j)
                    End If
                    rptBill.Sections("Indent").Controls(strControl).Caption = strValue
                Next j
            
                sSQL = "select 商品编码,品名,单位,颜色,尺寸,配送数量 as 数量 from psd where 表单号='" & Trim(txtPurcode.Text) & "' and 商品编码='" & Trim(RsTemp("商品编码")) & "' and 零售价=" & RsTemp("单价") & " order by 商品编码,颜色,尺寸"
                Set RP = Nothing
                RP.CursorLocation = adUseClient
                RP.Open sSQL, Conn, adOpenStatic, adLockPessimistic
                strControl = "lblR" & Trim(Str(N + 1))

                
                ColorAndSize = ColorAndSize & Trim(RP("商品编码"))
                PRECOLOR = ""
                While Not RP.EOF
                    If PRECOLOR <> Trim(RP("颜色")) Then
                        PRECOLOR = Trim(RP("颜色"))
                        ColorAndSize = ColorAndSize & Trim(RP("颜色")) & "[" & Trim(RP("尺寸")) & ":" & Trim(RP("数量")) & "]"
                    Else
                        ColorAndSize = ColorAndSize & "[" & Trim(RP("尺寸")) & ":" & Trim(RP("数量")) & "]"
                    End If
                    RP.MoveNext
                Wend

                ColorAndSize = ColorAndSize & vbCrLf
                Qty = Qty + RsTemp("数量")
                sum = sum + RsTemp("金额")
                RsTemp.MoveNext
            Next N
            rptBill.Sections("Indent").Controls("lblColorAndSize").Caption = ColorAndSize
    '        sum = Format(sum, DecNum)
            rptBill.Sections("Indent").Controls("lbl大写").Caption = D2X(sum)
            rptBill.Sections("Indent").Controls("lblSJ").Caption = "税金:" & Format(sum * 0.17 / 1.17, DecNum)
            rptBill.Sections("Indent").Controls("lblSum").Caption = Format(Qty, "#")
            rptBill.Sections("Indent").Controls("lblIamt").Caption = Format(sum, "#.00")
            
            If GetSetting("LSDSTAR", "库存设置", "显示付款方式", "1") = "1" Then
                rptBill.Sections("Indent").Controls("lblPayType").Caption = cmbPayType.Text
            Else
                rptBill.Sections("Indent").Controls("lblPayType").Visible = False
            End If
            
            If GetSetting("LSDSTAR", "库存设置", "显示业务员", "1") = "1" Then
                rptBill.Sections("Indent").Controls("lblYW").Caption = "业务：" & txtYWY.TheName
            End If
            
            RsTemp.MovePrevious
            rptBill.Sections("Indent").Controls("lblPage").Caption = "第 " & Str(Int((RsTemp.AbsolutePosition - 1) / 6) + 1) & " 页 共 " & Str(Int((RsTemp.RecordCount - 1) / 6) + 1) & " 页"
            RsTemp.MoveNext
            
            rptBill.Sections("Indent").Controls("lbltitle").Caption = GetSetting("LSDSTAR", "单据标题", "配送单", "配送单")
            rptBill.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
            rptBill.Sections("Indent").Controls("lblgrp").Caption = "部门:" & txtSuppName.Text
            rptBill.Sections("Indent").Controls("lblDate").Caption = "日期:" & txtPurdate.Text
            rptBill.Sections("Indent").Controls("lblBZ").Caption = "备注:" & txtRemark.Text
            rptBill.Sections("Indent").Controls("lblYH").Visible = False
            rptBill.Sections("Indent").Controls("lblIptno").Caption = "开票:" & txtIptno.TheName
        '    rptBill.Sections("Indent").Controls("lbl大写").Caption = D2X(Val(txtIamt0.Text))
        '    rptBill.Sections("Indent").Controls("lblSJ").Caption = Format(Val(txtIamt0.Text) * 0.17 / 1.17, "#.00")
        '    rptBill.Sections("Indent").Controls("lblIamt").Caption = Format(Val(txtIamt0.Text) * 0.17 / 1.17, "#.00")

            If GetSetting("LSDSTAR", "单据标题", "显示预览窗口", "1") = "1" Then
                rptBill.Show 1
            Else
                rptBill.PrintReport
            End If
            Unload rptBill
        Wend
        
       ' rptBill.PrintReport
'        Unload rptBill
    End If
    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
    '确认，删除，前项，后项
    cmdToolCommit.Caption = "弃审[&O]"
    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 CalTotalDelete
    '检查是否存在相同编号供应商编码.
    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
    End If
    '否则代销付款单允许修改.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Cmd.ActiveConnection = Conn
    
    Conn.BeginTrans
    
    If CommSaveTable Then
       '确认事务
       Conn.CommitTrans
       cmdPrev.Enabled = False
       cmdNext.Enabled = False
       cmdToolCommit.Caption = "审核[&O]"
       cmdDelete.Enabled = True
       '提示
        sb1.Panels(1).Text = "PSD已被保存。"
    Else
       '回卷事务
       Conn.RollbackTrans
       '提示
       sb1.Panels(1).Text = "PSD保存失败！"
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Exit Sub
MyErr:
    Conn.RollbackTrans
    MsgBox "保存失败." + Chr(13) + "原因:" + Err.Description, vbCritical
End Sub

Private Sub cmdToolJian_Click()
    Dim s, ss, Qty, prc, I
    If txtSuppno.Text = "" Then
        MsgBox "请先选择分店!", vbExclamation, "提示窗口"
        Exit Sub
    End If
    Load frmDist
    'Set frmDist.frm = Me
    frmDist.Show 1
    sSQL = "SELECT 品名,单位,进价,零售价,税率,含税进价 FROM 商品主档 WHERE 商品编码='" & frmDist.GCode & "'"
    Set RsTemp = Nothing
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
    
    If RsTemp.EOF Then
        MsgBox "该商品编码不存在!" & vbCrLf & "请检查输入是否正确或查询商品编码.", vbExclamation, "提示窗口"
        Exit Sub
    End If
        If frmDist.R <> "" Then
            
'            sSQL = "select * from 分店商品信息 where 商品编码='" & Trim(grdDET.Columns("商品编码").Text) & "' and 分店编码='" & Trim(txtSuppno.Text