frmpsout.frm

ktv场所的包房开房、迎宾、预定管理系统。

                .TextMatrix(.rows - 1, 6) = txt_total.text
                .rows = .rows + 1
            End With
            With flex_pro
                .TextMatrix(.row, 4) = Val(.TextMatrix(.row, 4)) - Val(msglist.TextMatrix(msglist.rows - 2, 5))
            End With
            
            totalprice
            
            CmdAct(7).SetFocus
            
        Case 3
            If msglist.rows > 2 And msglist.TextMatrix(msglist.row, 1) <> "" Then
                ru = MsgBox("确认删除?", 33, "询问")
                If ru = 2 Then
                    Exit Sub
                End If
                With flex_pro
                    For ru = 1 To .rows - 1
                        If Trim$(.TextMatrix(ru, 0)) = Trim$(msglist.TextMatrix(msglist.row, 1)) Then
                            .TextMatrix(ru, 4) = Val(.TextMatrix(ru, 4)) + Val(msglist.TextMatrix(msglist.row, 5))
                            Exit For
                        End If
                    Next ru
                End With
                msglist.RemoveItem (msglist.row)
                For ru = 1 To msglist.rows - 1
                    msglist.TextMatrix(msglist.rows - ru, 0) = msglist.rows - ru
                Next ru
            Else
                MsgBox "本行不能删除！", vbInformation, "信息"
            End If
            totalprice
            CmdAct(7).SetFocus
            
        Case 4
            If yesno1 = False Then
                frm_cgreport.Show
            Else
                If msglist.rows > 2 And cmdSave.Enabled = True Then
                    ru = MsgBox("放弃当前销售的数据?", 33, "询问")
                    If ru = 2 Then
                        Exit Sub
                    End If
                End If
            End If
            Unload Me
        Case 5
            txt_id = ""
            txt_qty = 0
            txtsa_maker.text = strCurUser
            dtptime.Value = Now
            'Comsupp = ""
            txt_memo = ""
            Combtype.Clear
            TxtSQL = "select employee_name from Employee "
            Set mrc = ExecuteSQL(TxtSQL, msgtext)
            Combtype.AddItem " "
            Do While Not mrc.EOF
                Combtype.AddItem mrc.Fields("employee_name")
                mrc.MoveNext
            Loop
            Combtype.ListIndex = 0
            msglist.Clear
            showtitle
            mrc.Close
            Set mrc = Nothing
            strsql = "select CountNum from counterid where TableName='psout_head'"
            rscount.Open strsql, cnn, adOpenDynamic, adLockOptimistic
            txtsa_id.text = Format(rscount!CountNum + 1, "00000")
            Call IsEdit(True)
            rscount.Close
            Combtype.SetFocus
        Case 6
            txt_qty = 0
            txt_name = ""
            txt_id = ""
            txt_total = ""
            txt_lb = ""
            combdj = ""
            combdw = ""
            txt_id.Enabled = True
            txt_id.SetFocus
        Case 7
            txt_qty.text = 0
            txt_name = ""
            txt_id = ""
            txt_total = ""
            txt_lb = ""
            combdj = ""
            combdw = ""
            txt_id.Enabled = True
            txt_id.SetFocus

            SendKeys "{Home}+{End}"
        Case 8
            
            Set txt = New clsText
            With txt
                .stringX = " "
                .fontsize = 10
                .Align = tymiddle
            End With
            rpt.Title.AddText "title2", txt
            Set txt = Nothing

            rpt.SetPrinter 11500.488, 13000.064, Portrait

            Set txt = New clsText
            With txt
                .stringX = "出库单"
                .fontsize = 12

                .FontBold = True
                .Align = tymiddle
            End With
            rpt.Header.AddText "head1", txt
            Set txt = Nothing
            
            Set txt = New clsText

            rpt.Header.AddText "head2", txt
            Set txt = Nothing
            Set txt = New clsText
            With txt
                .stringX = "单号:" & txtsa_id & Space(10) & "日期:" & dtptime.Value & Space(5)
                .fontsize = 10
                '.ForeColor = &H8000&
                '.FontBold = True
                .Align = tyLeft
                .orient = Portrait
            End With
            rpt.Header.AddText "head3", txt
            Set txt = Nothing
            
            Set txt = New clsText
            With txt
                .stringX = "领用人:" & Combtype.text & Space(10) & "领用部门:" & Comsupp.text & Space(5)
                .fontsize = 10
                '.ForeColor = &H8000&
                '.FontBold = True
                .Align = tyLeft
                .orient = Portrait
            End With
            rpt.Header.AddText "head4", txt
            Set txt = Nothing
            
            Set txt = New clsText
            With txt
                .stringX = "总成本价：" & Format(Label2.Caption, "0.000") & Space(5) & "总销售价：" & Format(Label1.Caption, "0.00") & Space(5) & "|制单人:" & txtsa_maker
                .fontsize = 10
                '.ForeColor = vbRed
                '.FontBold = True
                .Align = tyLeft
            End With
            rpt.Footer.AddText "footer1", txt
            Set txt = Nothing
            rpt.LeftSection.AlignMode = tyContent
            rpt.RightSection.AlignMode = tyContent
            rpt.Align = tymiddle
            BTarray(1) = 800
            BTarray(2) = 3400
            BTarray(3) = 600
            BTarray(4) = 600
            BTarray(5) = 1100
            BTarray(6) = 1200
            BTarray(7) = 1100
            BTarray(8) = 1200
            recBT(1) = "编号"
            recBT(2) = "名称"
            recBT(3) = "数量"
            recBT(4) = "单位"
            recBT(5) = "进价"
            recBT(6) = "金额"
            recBT(7) = "售价"
            recBT(8) = "金额"
            
            TxtSQL = "select a.p_id,a.p_name,a.qty,a.unit,format(a.unit_price,'0.000'),format(a.price,'0.000'),format(b.product_pst,'0.00'),format(a.qty*b.product_pst,'0.00') as sp"
            TxtSQL = TxtSQL & " from psout_detail as a, product as b where a.p_id = b.p_id and  order_id='" & txtsa_id & "'"
            Set mrc = ExecuteSQL(TxtSQL, msgtext)
            If mrc.EOF Then Exit Sub
            report = False
            rpt.Attachmrc mrc, recBT, BTarray
            rpt.Preview
            mrc.Close
            Set mrc = Nothing
    End Select
    Exit Sub
Err:
    MsgBox "错误号为：" & Err.Number & Chr(13) & "错误说明：" & Err.Description
    'Resume Next
End Sub

Private Sub IsEdit(blnIsEdit As Boolean)
    Dim intNum As Integer
    
    txt_id.Enabled = blnIsEdit
    Comsupp.Enabled = blnIsEdit
    Combtype.Enabled = blnIsEdit
    cmdSave.Enabled = blnIsEdit
'    combdw.Enabled = blnIsEdit
    txt_memo.Enabled = blnIsEdit
'    txt_name.Enabled = blnIsEdit
    dtptime.Enabled = blnIsEdit
    txt_qty.Enabled = blnIsEdit
'    combdj.Enabled = blnIsEdit
    msglist.Enabled = blnIsEdit
    flex_pro.Enabled = blnIsEdit
    
    For intNum = 2 To 3
        CmdAct(intNum).Enabled = blnIsEdit
    Next
    'CmdAct(1).Enabled = Not blnIsEdit
    CmdAct(5).Enabled = Not blnIsEdit
    CmdAct(6).Enabled = blnIsEdit
    CmdAct(7).Enabled = blnIsEdit
    If txtsa_id = "" Then
        For intNum = 2 To 3
            CmdAct(intNum).Enabled = False
        Next
    End If
End Sub



Private Sub DCbouser_KeyPress(KeyAscii As Integer)
    If KeyAscii = 13 Then
        CmdAct(2).SetFocus
    End If
End Sub

Private Sub cmdSave_Click()

    saveyesno = True
    If Combtype.text = "" Then
        MsgBox "领物人未填!", vbCritical, "错误"
        Combtype.SetFocus
        Exit Sub
    End If
    If msglist.rows <= 2 Then
        MsgBox "单据明细项不能为空!", vbCritical, "错误"
        Exit Sub
    End If

    If MsgBox("确认出库?", 33, "出库") = 2 Then
        Exit Sub
    End If
    Dim i As Long
    
On Error GoTo errdeal

cnn.BeginTrans

    With msglist
        For i = 1 To .rows - 1
            If Trim$(.TextMatrix(i, 1)) <> "" Then
                updatesales i
            End If
        Next
    End With
    cnn.Execute "update counterid set CountNum=CountNum+1 where TableName='psout_head' and val(countnum)< " & Val(txtsa_id.text)
    
cnn.CommitTrans

    MsgBox "数据保存完毕！", vbInformation
On Error Resume Next
    Call IsEdit(False)
    CmdAct(8).Enabled = True
    CmdAct(8).SetFocus
    Exit Sub
errdeal:
    MsgBox " 保存失败，请检查每个项目的正确性。" & Err.Description, vbCritical
    Err.Clear


End Sub


Private Sub Combdj_KeyPress(KeyAscii As Integer)
If KeyAscii = 13 Then
    CmdAct(2).SetFocus
End If
End Sub

Private Sub Combtype_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{TAB}"
    End If
End Sub

Private Sub Comsupp_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 13 Then
        SendKeys "{TAB}"
    End If
End Sub

Private Sub flex_pro_Click()
If flex_pro.row > 0 Then
        With flex_pro
            txt_id = "" & .TextMatrix(.row, 0)
            txt_name = "" & .TextMatrix(.row, 1)
            combdj = "" & .TextMatrix(.row, 3)
            combdw = "" & .TextMatrix(.row, 2)
            txt_qty.Enabled = True
            txt_qty.text = 1
            num = Val("" & .TextMatrix(.row, 4))
            txt_qty.SetFocus
            SendKeys "{Home}+{End}"
        End With
    End If
End Sub

Private Sub Form_Load()
Dim mrc As ADODB.Recordset
Dim TxtSQL As String
Dim msgtext As String

    
    Set rsProduct = DEjxc.rsComproductbycode
    Set cmProduct = New ADODB.Command
    cmProduct.ActiveConnection = cnn
    cmProduct.CommandType = adCmdText
    
    Set rsSaHA = DEjxc.rsComPsHA
    Set rsSalDA = DEjxc.rsComOrdDA
    Set rscount = New ADODB.Recordset
    Set rssql = New ADODB.Recordset
    Set cmSaHA = New ADODB.Command
    cmSaHA.ActiveConnection = cnn
    cmSaHA.CommandType = adCmdText
    showtitle
    If yesno1 = False Then
        cmdSave.Visible = False
'        CmdAct(1).Visible = False
        CmdAct(2).Visible = False
        CmdAct(3).Visible = False
        CmdAct(5).Visible = False
'        CmdAct(6).Visible = False
        CmdAct(7).Visible = False
        CmdAct(8).Visible = False
        txtsa_id = frm_cgreport.msglist1.TextMatrix(frm_cgreport.msglist1.row, 0)
        TxtSQL = "select ps_id,ps_date,ps_rid,ps_maker,ps_men,ps_demo"
        TxtSQL = TxtSQL & " from psout_head"
        TxtSQL = TxtSQL & " where ps_id='" & txtsa_id & "'"
        Set mrc = ExecuteSQL(TxtSQL, msgtext)
        If mrc.EOF Then Exit Sub
        txtsa_maker = "" & mrc.Fields("ps_maker")
        Combtype = "" & mrc.Fields("ps_men")
        Comsupp.ItemData(Comsupp.ListIndex) = "" & mrc.Fields("ps_rid")
        dtptime.Value = mrc.Fields("ps_date")
        txt_memo = "" & mrc.Fields("ps_demo")
        
        TxtSQL = "select * from psout_detail where order_id='" & txtsa_id & "'"
        Set mrc = ExecuteSQL(TxtSQL, msgtext)
        If mrc.EOF Then Exit Sub
        Do While Not mrc.EOF
            With FrmPsEdit.msglist
                .TextMatrix(.rows - 1, 0) = .rows - 1
                .TextMatrix(.rows - 1, 1) = mrc.Fields("p_id")
                .TextMatrix(.rows - 1, 2) = mrc.Fields("p_name")
                .TextMatrix(.rows - 1, 3) = mrc.Fields("unit")
                .TextMatrix(.rows - 1, 4) = mrc.Fields("unit_price")
                .TextMatrix(.rows - 1, 5) = mrc.Fields("qty")
                .TextMatrix(.rows - 1, 6) = mrc.Fields("price")
                .TextMatrix(.rows - 1, 7) = "" & mrc.Fields("type_id")
                .rows = .rows + 1
                mrc.MoveNext
            End With
        Loop
        msglist.Enabled = True
        mrc.Close
        Set mrc = Nothing
        totalprice
    Else
        Call IsEdit(False)
        intNumWindows = OpenWindow(intNumWindows)
        Call SetFormStu(Me, frmMain)
    End If
    
    TxtSQL = "select a.p_id,a.p_name,a.unit,b.product_cos,format(a.qty,'0') as qty,format(a.price,'0.00') as price,b.product_code,b.product_eno"
    TxtSQL = TxtSQL & " from mat_detail as a,product as b"
    TxtSQL = TxtSQL & " where a.p_id=b.p_id"
    TxtSQL = TxtSQL & " and (a.p_id<>'' and a.qty<>0)"
    TxtSQL = TxtSQL & " group by a.p_id,a.p_name,a.unit,b.product_cos,a.qty,a.price,b.product_code,b.product_eno,b.type_id"
    TxtSQL = TxtSQL & " order by b.type_id,a.p_name,a.p_id"
    Set mrc = ExecuteSQL(TxtSQL, msgtext)
    Set flex_pro.DataSource = mrc
    showtitle_pro
    flex_pro.Visible = False
    
    Comsupp.Clear
    TxtSQL = "select department_id,department_name from Department order by val(department_id) "
    Set mrc = ExecuteSQL(TxtSQL, msgtext)
    Do While Not mrc.EOF
        Comsupp.AddItem mrc.Fields("department_name")
        Comsupp.ItemData(Comsupp.NewIndex) = mrc.Fields("department_id")
        mrc.MoveNext
    Loop
    Comsupp.ListIndex = 0
    mrc.Close
    Set mrc = Nothing
End Sub

Private Sub Form_Unload(Cancel As Integer)
    intNumWindows = Closewindow(intNumWindows)
    
    'rscount.Close
    Set rsSaHA = Nothing
    Set rsSalDA = Nothing
    'Set rscount = Nothing
    Set cmSaHA = Nothing
    Set cmProduct = Nothing
End Sub

Private Sub msglist_DblClick()
        
        If msglist.rows = 1 Or msglist.TextMatrix(msglist.row, 1) = "" Then
            Exit Sub
        End If
        With msglist
            txt_id.text = .TextMatrix(.row, 1)
            txt_name.text = .TextMatrix(.row, 2)
            combdw = .TextMatrix(.row, 3)
            txt_qty.text = .TextMatrix(.row, 5)
            combdj = .TextMatrix(.row, 4)
            txt_total.text = .TextMatrix(.row, 6)
        End With
        txt_qty.SetFocus
        txt_qty.tag = txt_qty.text
        SendKeys "{Home}+{End}"
'        CmdAct(1).Enabled = True
        cmdSave.Enabled = False
        CmdAct(2).Enabled = False