frmchainpdd.frm

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

    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
    Call CalTotal
    sSQL = "select 商品编码,品名,单位,sum(配送数量) as 数量,零售价 as 单价,sum(售价金额) as 金额 from LSChainPDD  where 表单号='" & Trim(txtPurcode.Text) & "' group by 商品编码,品名,单位,零售价"
    Set RsTemp = Nothing
    RsTemp.CursorLocation = adUseClient
    RsTemp.Open sSQL, Conn, adOpenStatic, adLockPessimistic
    
    If GetSetting("LSDSTAR", "库存设置", "打印零售价", "1") = "0" Then
    Else
        Load rptBill
        rptBill.Sections("Indent").Controls("lbltitle").Caption = GetSetting("LSDSTAR", "单据标题", "配送单", "配送单")
        rptBill.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
        rptBill.Sections("Indent").Controls("lblgrp").Caption = "分店:" & txtSuppno.Columns("部门名称").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")
        
        While Not RsTemp.EOF
            sum = 0
            Qty = 0
            For N = 0 To 5
                If RsTemp.EOF Then Exit For
                For j = 0 To 6
                    If j = 3 Or j = 4 Or j = 5 Then
                        strControl = "lblc" & (j + 1) & "r" & N + 1
                        strValue = Format(RsTemp(j), DecNum)
                    ElseIf j = 0 Or j = 1 Or j = 2 Then
                        strControl = "lblc" & (j + 1) & "r" & N + 1
                        strValue = RsTemp(j)
                    End If
                    rptBill.Sections("Indent").Controls(strControl).Caption = strValue
                    
                    sSQL = "select 商品编码,品名,单位,颜色,尺寸,配送数量 as 数量 from LSChainPDD where 表单号='" & Trim(txtPurcode.Text) & "' and 商品编码='" & Trim(RsTemp("商品编码")) & "'"
                    Set RP = Nothing
                    RP.CursorLocation = adUseClient
                    RP.Open sSQL, Conn, adOpenStatic, adLockPessimistic
                    strControl = "lblR" & Trim(Str(N + 1))
                    strValue = "商品编码:" & Trim(RP("商品编码")) & "[颜色:尺寸:数量]"
                    While Not RP.EOF
                        strValue = strValue & "[" & Trim(RP("颜色")) & ":" & Trim(RP("尺寸")) & ":" & Trim(RP("数量")) & "]"
                        RP.MoveNext
                    Wend
                    rptBill.Sections("Indent").Controls(strControl).Caption = strValue
                Next j
                Qty = Qty + RsTemp("数量")
                sum = sum + RsTemp("金额")
                RsTemp.MoveNext
            Next N
    '        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, DecNum)
            rptBill.Sections("Indent").Controls("lblIamt").Caption = Format(sum, DecNum)
            
            RsTemp.MovePrevious
            rptBill.Sections("Indent").Controls("lblPage").Caption = "第 " & Str(Int((RsTemp.AbsolutePosition - 1) / 6) + 1) & " 页 共 " & Str(Int((RsTemp.RecordCount - 1) / 6) + 1) & " 页"
            RsTemp.MoveNext
            
            If GetSetting("LSDSTAR", "单据标题", "显示预览窗口", "1") = "1" Then
                rptBill.Show 1
            Else
                rptBill.PrintReport
            End If
        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 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
    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 = "LSChainPDD已被保存。"
    Else
       '回卷事务
       Conn.RollbackTrans
       '提示
       sb1.Panels(1).Text = "LSChainPDD保存失败！"
    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) & "'"
'            Set RsTemp = Nothing
'            RsTemp.Open sSQL, Conn, adOpenStatic, adLockOptimistic
'
'            If Not RsTemp.EOF Then prc = RsTemp("配送价")
            
            sSQL = "SELECT * FROM 商品主档 WHERE 商品编码='" & Trim(frmDist.GCode) & "'"
            Set RsTemp = Nothing
            RsTemp.Open sSQL, Conn, adOpenStatic, adLockReadOnly
            If RsTemp.EOF Then
                MsgBox "该商品编码不存在！" & grdDET.Columns("商品编码").Text & "!", vbExclamation, "提示窗口"
                Exit Sub
            End If
            
            Load frmChainPrc
            Call frmChainPrc.InitData(frmDist.GCode, txtSuppno.Text)
            frmChainPrc.Show 1
            prc = frmChainPrc.prc
            
            ss = frmDist.R
            
            I = 1
            While I <= Len(ss)
                s = ""
                Qty = ""
                While Mid(ss, I, 1) <> "#" And I <= Len(ss)
                    If Mid(ss, I, 1) = "@" Then
                        s = s & vbTab
                    ElseIf Mid(ss, I, 1) = "$" Then
                        Qty = ""
                        s = s & vbTab & Str(prc) & vbTab
                    Else
                        Qty = Qty & Mid(ss, I, 1)
                        s = s & Mid(ss, I, 1)
                    End If
                    I = I + 1
                Wend
                I = I + 1
                Temp = frmDist.GCode & vbTab & RsTemp("品名") & vbTab & _
                        RsTemp("单位") & vbTab & s & vbTab & Str(Qty * prc)
                grdDET.AddItem Temp
            Wend
        End If
        Unload frmDist

End Sub


'改变确认状态
'只有审核员才能进行该操作
Private Sub cmdToolCommit_Click()
    If GetSetting("LSDSTAR", "库存设置", "使用存储过程", "1") = "0" Then
        If cmdToolCommit.Caption = "审核[&O]" Then
            AcceptVil (True)
        Else
            AcceptVil (False)
        End If
    Else
        Cmd.ActiveConnection = Conn
        If cmdToolCommit.Caption = "审核[&O]" Then