frmbill.frm

一个设计销售订单的源码；可以通过修改成为通用的单据控件

        MsgBox "单据【" & mBillID & "】可能已被删除！请刷新数据！", vbInformation, gConTitle
        Exit Function
    End If
    If Trim(rstTmp!FCheck) & "" <> "" Then
        gConn.RollbackTrans
        glngLevel = 0
        Set rstTmp = Nothing
        MsgBox "单据【" & mBillID & "】已被审核，不能删除！请刷新数据！", vbInformation, gConTitle
        Exit Function
    End If
    gConn.RollbackTrans
    glngLevel = 0
    Set rstTmp = Nothing
    
    mstate = isedit
    Call SetRight(isedit)
    Exit Function
Err:
    Set rstTmp = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'新增单据
Public Function AddNew() As Boolean
On Error GoTo Err
    Dim lngI        As Long
    Dim FID         As String
    Dim strSQL      As String
    Dim rstTmp      As ADODB.Recordset
    
    FID = frmSBill.GetID
    If FID = "" Then
        Call Cancel
        Exit Function
    End If
    strSQL = "SELECT * FROM t_GP_JDBill WHERE FID='" & FID & "'"
    Set rstTmp = GetRecordset(strSQL)
    '显示表头
    With rstTmp
        txtID.Text = !FID
        dtpDate.Value = !FDate
        txtDept.Text = !FDept
        vfgCbo(0).TextMatrix(0, 0) = !FType
        txtName.Text = !FName
        txtNo.Text = !FNo
        txtDonne.Text = !FDonne
        vfgCbo(1).TextMatrix(0, 0) = !FHurry
        vfgCbo(2).TextMatrix(0, 0) = !FSecret
        chkIsNo.Value = IIf(!FIsNo, 1, 0)
        txtState.Text = GetState(!FState)
    End With
   
    txtPrepare.Text = gstrUserName
    txtPrepare.Tag = gstrUser
    txtBillID.Text = AutoID("t_GP_QYBill", "FBillID", "QY")
    
    '显示表体
    '照排
    strSQL = "SELECT b.FProcessNumber,b.FProcessName,c.FUnit,b.FQty,FPrice=isNull(c.FPrice,0) FROM t_GP_PEBill a " & _
             "LEFT JOIN t_GP_PEBillEntry b on b.FBillID=a.FBillID " & _
             "LEFT JOIN t_GP_Item3 c on c.FItemNumber=b.FProcessNumber " & _
             "WHERE a.FCheck<>'' AND a.FID='" & FID & "'"
    '印刷
    strSQL = strSQL & " Union ALL " & vbCrLf & _
             "SELECT b.FProcessNumber,b.FProcessName,c.FUnit,b.FQty,FPrice=isNull(c.FPrice,0) FROM t_GP_YEBill a " & _
             "LEFT JOIN t_GP_YEBillEntry b on b.FBillID=a.FBillID " & _
             "LEFT JOIN t_GP_Item3 c on c.FItemNumber=b.FProcessNumber " & _
             "WHERE a.FCheck<>'' AND a.FID='" & FID & "'"
    '装订
    strSQL = strSQL & " Union ALL " & vbCrLf & _
             "SELECT b.FProcessNumber,b.FProcessName,c.FUnit,b.FQty,FPrice=isNull(c.FPrice,0) FROM t_GP_ZEBill a " & _
             "LEFT JOIN t_GP_ZEBillEntry b on b.FBillID=a.FBillID " & _
             "LEFT JOIN t_GP_Item3 c on c.FItemNumber=b.FProcessNumber " & _
             "WHERE a.FCheck<>'' AND a.FID='" & FID & "'"
    '纸张
    strSQL = strSQL & " Union ALL " & vbCrLf & _
             "SELECT FProcessNumber=b.FProjectNumber,FProcessName=isNull(b.FProjectName,'纸张'),c.FUnit,FQty=isNull(sum(b.FQty),0),FPrice=isNull(c.FPrice,0) " & _
             "from t_GP_LLBill a " & _
             "left join t_GP_LLBillEntry b on b.FBillID=a.FBillID " & _
             "LEFT JOIN t_GP_Item9 c on c.FItemNumber=b.FProjectNumber " & _
             "WHERE a.FCheck<>'' and a.FID='" & FID & "' " & _
             "Group by b.FProjectNumber,b.FProjectName,c.FUnit,c.FPrice"
    strSQL = strSQL & " Union ALL " & vbCrLf & _
             "SELECT FProcessNumber='',FProcessName='加收费',FUnit='',FQty=0,FPrice=0 "
    strSQL = strSQL & " Union ALL " & vbCrLf & _
             "SELECT FProcessNumber='',FProcessName='合计',FUnit='',FQty=0,FPrice=0"
    
    '单位
    strSQL = "SELECT t.FProcessNumber,t.FProcessName,t.FUnit,t.FQty,t.FPrice FROM (" & _
             strSQL & " ) t  "
    Set rstTmp = GetRecordset(strSQL)
    If rstTmp.RecordCount > 0 Then
        rstTmp.MoveFirst
        With vfgList
            .Rows = rstTmp.RecordCount + 1
            For lngI = 1 To rstTmp.RecordCount
                .TextMatrix(lngI, conID) = lngI
                .TextMatrix(lngI, conProjectNumber) = rstTmp!FProcessNumber
                .TextMatrix(lngI, conProjectName) = rstTmp!FProcessName
                .TextMatrix(lngI, conQty) = rstTmp!FQty
                .TextMatrix(lngI, conUnit) = rstTmp!FUnit & ""
                .TextMatrix(lngI, conPrice) = rstTmp!FPrice
                .TextMatrix(lngI, conMoney) = FormatNumber(.ValueMatrix(lngI, conQty) * .ValueMatrix(lngI, conPrice), 2)
                rstTmp.MoveNext
            Next
            
        End With
    Else
        MsgBox "该业务没有完工的工序！", vbInformation, gConTitle
        Call Cancel
        Exit Function
    End If
    mstate = isadd
    Call SetRight(mstate)
    Set rstTmp = Nothing
    AddNew = True
    Exit Function
Err:
    Set rstTmp = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'取消
Private Function Cancel() As Boolean
    If mBillID <> "" Then
        RefreshBill
        SetRight (isview)
        mstate = isview
    Else
        Quit
    End If
End Function

'审核单据
Private Function CheckBill() As Boolean
On Error GoTo Err
    Dim rstTmp      As ADODB.Recordset
    Dim strSQL      As String
    Dim strCheck    As String
    
    strSQL = "SELECT FCheck FROM t_GP_QYBill WHERE FBillID='" & mBillID & "'"
    glngLevel = gConn.BeginTrans
    Set rstTmp = GetRecordset(strSQL)
    strSQL = ""
    If Trim(rstTmp!FCheck) & "" <> "" Then
        strCheck = "反审核"
        If MsgBox("单据【" & mBillID & "】已被审核，您确定要" & strCheck & "这张单据吗？" _
                  & vbCrLf & "反审核将取消该业务的应收款。", vbYesNo + vbQuestion, gConTitle) = vbYes Then
            strSQL = "UPDATE t_GP_QYBill SET FCheck='' WHERE FBillID='" & mBillID & "'"
            strSQL = strSQL & "DELETE FROM t_GP_MoneyBalance WHERE FID='" & txtID.Text & "'"
        Else
            gConn.RollbackTrans
            Set rstTmp = Nothing
            glngLevel = 0
        End If
    Else
        strCheck = "审核"
        If MsgBox("单据【" & mBillID & "】未审核，您确定要" & strCheck & "这张单据吗？" _
                    & vbCrLf & "审核将产生该业务的应收款。", vbYesNo + vbQuestion, gConTitle) = vbYes Then
            strSQL = "UPDATE t_GP_QYBill SET FCheck='" & gstrUserName & "' WHERE FBillID='" & mBillID & "'"
            strSQL = strSQL & vbCrLf & _
                    "INSERT INTO t_GP_MoneyBalance " & _
                    "SELECT FInterID=1,FDeptID=b.FNumber,FDeptName=a.FDept,FRemark=a.FBillID," & _
                    "FDate=Getdate(),FID=a.FID,FMoney=a.FSumMoney,FRecMoney=0 FROM t_GP_QYBill a " & _
                    "LEFT JOIN t_GP_Item b on b.FClassNumber='1' and b.FName=a.FDept " & _
                    "WHERE a.FBillID='" & mBillID & "'"
        Else
            gConn.RollbackTrans
            Set rstTmp = Nothing
            glngLevel = 0
        End If
    End If
    If strSQL <> "" Then
        gConn.Execute strSQL
        gConn.CommitTrans
        glngLevel = 0
        MsgBox "单据【" & mBillID & "】" & strCheck & "成功！", vbInformation, gConTitle
    End If
    Call RefreshBill
    CheckBill = True
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'退出
Private Sub Quit()
    On Error Resume Next
    Unload Me
    Set frmBill = Nothing
    Set gConn = Nothing
End Sub

'同步单元格内容=被编辑的内容
Private Sub vfgList_ChangeEdit()
    Dim lngI        As Long
    Dim dblMoney    As Double
    With vfgList
'        If .Col = conQty Then .EditText = FormatNumber(.EditText, 2)
        .TextMatrix(.Row, .Col) = .EditText
        If .Col = conPrice Or .Col = conQty Then
            .TextMatrix(.Row, conMoney) = FormatNumber(.ValueMatrix(.Row, conQty) * .ValueMatrix(.Row, conPrice), 2)
            For lngI = 1 To .Rows - 2
                dblMoney = dblMoney + .ValueMatrix(lngI, conMoney)
            Next
            .TextMatrix(.Rows - 1, conMoney) = FormatNumber(dblMoney, 2)
        End If
    End With
End Sub

'进入单元格
Private Sub vfgList_EnterCell()
    If mstate = isadd Or mstate = isedit Then
        With vfgList
            If .TextMatrix(.Row, conProjectName) = "合计" Then Exit Sub
            Select Case .Col
                Case conID, conUnit, conMoney
'                Case conProjectNumber
'                    .EditCell
                Case Else
                    .EditCell
            End Select
        End With
    End If
End Sub

'F7选择工序
Private Sub vfgList_KeyDownEdit(ByVal Row As Long, ByVal Col As Long, KeyCode As Integer, ByVal Shift As Integer)
On Error GoTo Err
    Dim rstItem     As ADODB.Recordset
    Select Case Col
        Case conProjectNumber
            If KeyCode = vbKeyF7 Then
                If GetItemRst("3", rstItem) Then
                    If frmItem.GetItem(rstItem) Then
                        With vfgList
                            .TextMatrix(Row, conProjectName) = Trim(rstItem!FName)
                            .TextMatrix(Row, conProjectNumber) = Trim(rstItem!FNumber)
                            .TextMatrix(Row, conUnit) = Trim(rstItem!FUnit & "")
                            Set rstItem = Nothing
                            If Row = .Rows - 1 Then .Rows = .Rows + 1
                            .TextMatrix(.Rows - 1, conID) = .Rows - 1
                            .Select Row, conQty
                            .EditCell
                        End With
                    End If
                End If
            Else
                If KeyCode = vbKeyReturn Then
                    With vfgList
                        .Select Row, conQty
                        .EditCell
                    End With
                Else
                   If Not (KeyCode = vbKeyLeft Or KeyCode = vbKeyRight _
                            Or KeyCode = vbKeyUp Or KeyCode = vbKeyDown) Then KeyCode = 0
                End If
            End If
'        Case conWorker
'            If KeyCode = vbKeyF7 Then
'                If GetItemRst("2", rstItem) Then
'                    If frmItem.GetItem(rstItem) Then
'                        With vfgList
'                            .TextMatrix(Row, conWorker) = Trim(rstItem!FName)
''                            .TextMatrix(Row, conProjectNumber) = Trim(rstItem!FNumber)
'                            Set rstItem = Nothing
'                            .Select Row, conRemark
'                            .EditCell
'                        End With
'                    End If
'                End If
'            Else
'                If KeyCode = vbKeyReturn Then
'                    With vfgList
'                        .Select Row, conRemark
'                        .EditCell
'                    End With
'                Else
'                   If Not (KeyCode = vbKeyLeft Or KeyCode = vbKeyRight _
'                            Or KeyCode = vbKeyUp Or KeyCode = vbKeyDown) Then KeyCode = 0
'                End If
'            End If
        Case Else
            If KeyCode = vbKeyReturn Then
                With vfgList
                    If Col < .Cols - 1 Then
                        .Select Row, Col + 1
                        .EditCell
                    End If
                End With
            End If
    End Select
    Exit Sub
Err:
    Set rstItem = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Sub

'输入限制
Private Sub vfgList_KeyPressEdit(ByVal Row As Long, ByVal Col As Long, KeyAscii As Integer)
    If KeyAscii = 39 Then
        '禁止录入单引号
        KeyAscii = 0
        Exit Sub
    End If
    With vfgList
        If (Col = conQty Or Col = conPrice) Then
            ' 只允许输入数字，小数点，BACKSPACE
            If Not (KeyAscii > 44 And KeyAscii < 58 Or _
                    KeyAscii = 8 Or KeyAscii = 13) Then KeyAscii = 0
            If KeyAscii = 46 And InStr(1, .EditText, ".") > 0 Then KeyAscii = 0
        End If
    End With
End Sub

'开始编辑
Private Sub vfgList_StartEdit(ByVal Row As Long, ByVal Col As Long, Cancel As Boolean)
    If (Col = conID Or Col = conUnit Or Col = conMoney Or Col = conProjectName) Then Cancel = True
    If vfgList.TextMatrix(Row, conProjectName) = "合计" Then Cancel = True
'    If Col <> conProjectNumber And vfgList.TextMatrix(Row, conProjectNumber) = "" Then Cancel = True
End Sub


Private Sub vfgList_ValidateEdit(ByVal Row As Long, ByVal Col As Long, Cancel As Boolean)
    If Col = conProjectNumber Then
        With vfgList
            If Len(Trim(.EditText)) > 0 Then
                If Row = .Rows - 1 Then
                    .AddItem "", Row + 1
'                    .Rows = .Rows + 1
                    .TextMatrix(.Rows - 1, conID) = .Rows - 1
                End If
            End If
        End With
    End If
End Sub

'打印设置
Private Function PrintSetup() As Boolean
On Error GoTo Err
    Dim objForm     As Object
    Set objForm = CreateObject("PrintSet.Application")
    PrintSetup = objForm.PrintSetup(gConn, ModQYBill)
    Set objForm = Nothing
    Exit Function
Err:
    Set objForm = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'打印
Private Function PrintBill() As Boolean
On Error GoTo Err
    Dim objForm     As Object
    Set objForm = CreateObject("PrintBill.Application")
    PrintBill = objForm.BillPrint(gConn, ModQYBill, mBillID, True)
    Set objForm = Nothing
    Exit Function
Err:
    Set objForm = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'增行
Private Function AddRow() As Boolean
    With vfgList
        If .Row > 0 Then
            .AddItem "", .Row
            .Clear 2, 0
        End If
    End With
    Call RefreshNo
End Function

'删行
Private Function DelRow() As Boolean
    Dim lngRow      As Long
    With vfgList
        If .Row < 1 Then Exit Function
        lngRow = .Row
        If .TextMatrix(lngRow, conProjectName) = "合计" Then Exit Function
        If .Rows > 2 Then
            .RemoveItem lngRow
            If lngRow < .Rows Then
                .Select lngRow, .Col
            Else
                If lngRow > 1 Then .Select lngRow - 1, conQty
            End If
        Else
            .Clear 2, 0
        End If
    End With
    Call RefreshNo
End Function

'排序
Private Function RefreshNo() As Boolean
    Dim lngI        As Long
    With vfgList
        For lngI = 1 To .Rows - 1
            .TextMatrix(lngI, conID) = lngI
        Next
    End With
End Function

'合计
Private Function SumMoney() As Boolean
    Dim dblMoney        As Double
    Dim lngI            As Long
    With vfgList
        For lngI = 1 To .Rows - 2
            dblMoney = dblMoney + .ValueMatrix(lngI, conMoney)
        Next
        .TextMatrix(.Rows - 1, conMoney) = dblMoney
    End With
End Function