frm

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

            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("S金额")

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

        If GetSetting("LSDSTAR", "单据标题", "显示预览窗口", "1") = "1" Then
            rptSJBill.Show 1
        Else
            rptSJBill.PrintReport
        End If
        Unload rptSJBill
    Wend
       ' rptBill.PrintReport
'        Unload rptBill

End Sub


Private Sub PrintLSJ()
    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
    
    '        Load rptlsbill
    ColorAndSize = ""
    While Not RsTemp.EOF
        Load rptLSBill
        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
                rptLSBill.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("金额")
            
            Set RR = Nothing
            RR.Open "select 零售价 from 商品主档 where 商品编码='" & RsTemp("商品编码") & "'", Conn, adOpenStatic, adLockReadOnly
            If Not RR.EOF Then
               rptLSBill.Sections("Indent").Controls("lblLSJ" & CStr(N + 1)).Caption = RR("零售价")
            End If
            
            RsTemp.MoveNext
        Next N
        rptLSBill.Sections("Indent").Controls("lblColorAndSize").Caption = ColorAndSize
'        sum = Format(sum, DecNum)
        rptLSBill.Sections("Indent").Controls("lbl大写").Caption = D2X(sum)
        rptLSBill.Sections("Indent").Controls("lblSJ").Caption = "税金:" & Format(sum * 0.17 / 1.17, DecNum)
        rptLSBill.Sections("Indent").Controls("lblSum").Caption = Format(Qty, "#")
        rptLSBill.Sections("Indent").Controls("lblIamt").Caption = Format(sum, "#.00")
        
'        If GetSetting("LSDSTAR", "库存设置", "显示付款方式", "1") = "1" Then
'            rptLSBill.Sections("Indent").Controls("lblPayType").Caption = cmbPayType.Text
'        Else
'            rptLSBill.Sections("Indent").Controls("lblPayType").Visible = False
'        End If
'
'        If GetSetting("LSDSTAR", "库存设置", "显示业务员", "1") = "1" Then
'            rptLSBill.Sections("Indent").Controls("lblYW").Caption = "业务：" & txtYWY.TheName
'        End If
        
        RsTemp.MovePrevious
        rptLSBill.Sections("Indent").Controls("lblPage").Caption = "第 " & Str(Int((RsTemp.AbsolutePosition - 1) / 6) + 1) & " 页 共 " & Str(Int((RsTemp.RecordCount - 1) / 6) + 1) & " 页"
        RsTemp.MoveNext
        
        rptLSBill.Sections("Indent").Controls("lbltitle").Caption = "分店销售单"  ' GetSetting("LSDSTAR", "单据标题", "配送单", "配送单")
        rptLSBill.Sections("Indent").Controls("lblno").Caption = "NO:" & txtPurcode.Text
        rptLSBill.Sections("Indent").Controls("lblgrp").Caption = "部门:" & txtSuppName.Text
        rptLSBill.Sections("Indent").Controls("lblDate").Caption = "日期:" & txtPurdate.Text
        rptLSBill.Sections("Indent").Controls("lblBZ").Caption = "备注:" & txtRemark.Text
'        If txtDD.Text <> "" Then rptLSBill.Sections("Indent").Controls("lblBZ").Caption = "备注:" & txtRemark.Text & "(订单号:" & Trim(txtDD.Text) & ")"
        rptLSBill.Sections("Indent").Controls("lblYH").Visible = True
        rptLSBill.Sections("Indent").Controls("lblIptno").Caption = "开票:" & txtIptno.TheName
    '    rptlsbill.Sections("Indent").Controls("lbl大写").Caption = D2X(Val(txtIamt0.Text))
    '    rptlsbill.Sections("Indent").Controls("lblSJ").Caption = Format(Val(txtIamt0.Text) * 0.17 / 1.17, "#.00")
    '    rptlsbill.Sections("Indent").Controls("lblIamt").Caption = Format(Val(txtIamt0.Text) * 0.17 / 1.17, "#.00")

        If GetSetting("LSDSTAR", "单据标题", "显示预览窗口", "1") = "1" Then
            rptLSBill.Show 1
        Else
            rptLSBill.PrintReport
        End If
        Unload rptLSBill
    Wend
End Sub



Private Sub SetButtonState(d As Boolean)
    If d Then
        cmdToolCommit.Caption = "弃审[&O]"
        cmdSave.Enabled = False
        cmdDelete.Enabled = False
        grdDET.AllowUpdate = False
        grdDET.SelectByCell = True
    Else
        cmdToolCommit.Caption = "审核[&O]"
        cmdSave.Enabled = True
        cmdDelete.Enabled = True
        grdDET.AllowUpdate = True
        grdDET.SelectByCell = False
    End If
End Sub


Private Function AcceptVil(d As Boolean) As Boolean
    On Error GoTo ComErr
    Dim I As Integer
    Dim RsS As New ADODB.Recordset
    Dim sSQL As String, Qty As Single
    If Not DataIsOK() Then
        MsgBox "表单数据存在错误!", vbExclamation, "提示窗口"
        Exit Function
    End If
    If Not CommSaveTable() Then
       MsgBox "保存数据时发生错误!", vbExclamation, "错误窗口"
       Exit Function
    End If
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    Conn.BeginTrans
    
    If d Then
        sSQL = "UPDATE " & TableName & " SET 确认状态=1 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Else
       sSQL = "UPDATE " & TableName & " SET 确认状态=0 WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    End If
    
    Cmd.CommandText = sSQL
    Cmd.Execute
    
    sSQL = "select 商品编码,品名,单位,颜色,尺寸,配送数量 as 数量,零售价 as 单价 from LSChainXSD where 表单号='" & Trim(txtPurcode.Text) & "'"
    Set RsS = Nothing
    RsS.Open sSQL, Conn, adOpenStatic, adLockReadOnly

    
    While Not RsS.EOF
        If Not d Then
            Qty = -RsS("数量")
        Else
            Qty = RsS("数量")
        End If
        
       
        If Not OutSubStock(txtSuppno, RsS("商品编码"), RsS("品名"), _
              RsS("单位"), RsS("颜色"), RsS("尺寸"), -Qty) Then
            MsgBox "确认失败!,请检查数据是否正确!", vbInformation, "提示窗口"
            Conn.RollbackTrans
            Exit Function
        End If
        RsS.MoveNext
    Wend

    '确认，保存，删除
    Call SetButtonState(d)
    
    Conn.CommitTrans
    Exit Function
ComErr:
    ErrNum = Err.number
    Conn.RollbackTrans
    MsgBox "确认失败!,请检查数据是否正确!" & vbCrLf & Error$(Err.number), vbExclamation, "提示窗口"
End Function

Private Sub ShowPosition()
    On Error Resume Next
    sb1.Panels(1).Text = "共" & Trim(Str(QueryRs.RecordCount)) & "条,第:" & Trim(Str(QueryRs.AbsolutePosition)) & "条"
End Sub

'进入查询状态
Private Sub BeginQuery()
    cmdNew.Enabled = False
    cmdSave.Enabled = False
    cmdToolCommit.Caption = "弃审[&O]"
    cmdDelete.Enabled = False
    QueryFlag = True
    cmdQuery.Caption = "开始[&Q]"
End Sub

'恢复查询前的状态
Private Sub RestoreState()
    Call RefreshTable(" ")
    cmdNew.Enabled = True
    cmdSave.Enabled = True
    cmdToolCommit.Caption = "审核[&O]"
    cmdDelete.Enabled = True
    cmdQuery.Caption = "查询[&Q]"
End Sub

'完成查询
Private Sub CommitQuery()
    On Error GoTo MyErr
    Dim strSQL As String
    Dim strTemp As String
    strSQL = "SELECT 表单号 FROM " & TableName & " WHERE "
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If (Trim(txtPurcode.Text) <> "") Then
       strTemp = "表单号 LIKE '" & Trim(txtPurcode.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    '配送日期
    If (Trim(txtPurdate.Text) <> "") Then
       strTemp = " 配送日期 = '" & Trim(txtPurdate.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    If Trim(grdDET.Columns(1).Text) <> "" Then
       strTemp = " 商品编码 like '" & Trim(grdDET.Columns(1).Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    '录入员
    If (Trim(txtIptno.Text) <> "") Then
       strTemp = "录入员 LIKE '" & Trim(txtIptno.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    If (Trim(txtSuppno.Text) <> "") Then
       strTemp = "分店编码 LIKE '" & Trim(txtSuppno.Text) & "' AND "
       strSQL = strSQL & strTemp
    End If
    ''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
    If (Right(Trim(strSQL), 5) = "WHERE") Then
       strSQL = Left(Trim(strSQL), Len(Trim(strSQL)) - 5)
    Else
        strSQL = Left(Trim(strSQL), Len(Trim(strSQL)) - 3)
    End If
    strSQL = strSQL & "  group by 表单号  order by  表单号 desc "
    RestoreState
    Set QueryRs = Nothing
    QueryRs.CursorLocation = adUseClient
    QueryRs.Open strSQL, Conn, adOpenDynamic, adLockReadOnly
    If (Not QueryRs.EOF) Then
       RefreshTable (QueryRs("表单号"))
       cmdPrev.Enabled = True
       cmdNext.Enabled = True
    Else
       Call RefreshTable("")
       cmdPrev.Enabled = False
       cmdNext.Enabled = False
    End If
    Exit Sub
MyErr:
    MsgBox "查询条件或者数据库发生错误,请检查." & Chr(13) & "错误信息:" & Err.Description, vbCritical
End Sub

Private Function CommSaveTable() As Boolean
    Dim sSQL As String
    On Error GoTo CommSaveErr
    sSQL = "DELETE FROM " & TableName & " WHERE 表单号='" & Trim(txtPurcode.Text) & "'"
    Cmd.ActiveConnection = Conn
    Cmd.CommandText = sSQL
    Cmd.Execute
    If SaveTable() Then
        CommSaveTable = True
        Exit Function
    Else
        CommSaveTable = False
        Exit Function
    End If
    Exit Function
CommSaveErr:
    CommSaveTable = False
End Function