frm分店销售单.frm

服装销售系统,VB开发.没有解压密码

'
'检查数据是否合法
Private Function DataIsOK() As Boolean
    If Trim(txtPurcode.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("表单号")
    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 = vRs("分店名称")

    txtIptno.Text = vRs("录入员")
    
    If Trim(vRs("备注")) <> "0" Then txtRemark.Text = vRs("备注") Else txtRemark.Text = ""
    
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    '如果确认状态为真则不允许修改
    If vRs("确认状态") Then
        cmdToolCommit.Caption = "弃审[&O]"
        cmdSave.Enabled = False
        cmdDelete.Enabled = False
    Else
        cmdToolCommit.Caption = "审核[&O]"
        cmdSave.Enabled = True
        cmdDelete.Enabled = True
    End If
    grdDET.RemoveAll
    While Not vRs.EOF
        Temp = vRs("商品编码") & vbTab & vRs("品名") & vbTab & Trim(vRs("单位")) & _
              vbTab & Trim(vRs("颜色")) & _
              vbTab & Trim(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(txtPurdate.Text) & "','" & _
            Trim(txtSuppno.Text) & "','" & _
            Trim(txtSuppName.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) & ",0,'" & _
            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 (" ")
    If GetSetting("LSDSTAR", "进销管理", "配送单单号是否自动生成", "1") = "1" Then
        txtPurcode.Text = GeneratePurcode(TableName)
    End If    '确认，保存，删除
    txtPurdate.Text = Format(Now, "yyyy-mm-dd")
    cmdToolCommit.Caption = "审核[&O]"
    cmdSave.Enabled = True
    cmdDelete.Enabled = False
    cmdPrev.Enabled = False
    cmdNext.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 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 lschainxsd  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 lschainxsd 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
    '如果存在