frmbill.frm

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

Private Sub txtID_GotFocus()
    If mstate = isedit Then Clipboard.Clear
End Sub

'密级和序号处理
Private Sub vfgCbo_ChangeEdit(Index As Integer)
    If Index = 2 Then
        With vfgCbo(Index)
'            Debug.Print .EditText
            If .EditText = "机密" Or .EditText = "绝密" Then
                chkIsNo.Enabled = True
            Else
                chkIsNo.Enabled = False
                chkIsNo.Value = 0
            End If
        End With
    End If
End Sub

'初始化
Public Function Init(ByVal Flag As State, ByVal BillID As String) As Boolean
On Error GoTo Err
    mstate = Flag
    If Not TestConn Then
        MsgBox "数据库连接有错。", vbInformation, gConTitle
        Exit Function
    End If
    '检查权限
    mstrAuth = GetUserRight(gstrUser, ModQYBill)
    If Not Left(mstrAuth, 1) = "1" Then
        MsgBox "您没有使用本模块的权限！", vbInformation, gConTitle
        Exit Function
    End If
    mBillID = BillID
    '---------------------------
    '初始化下拉框
    Call InitCbo
'    dtpDate = Now
    '---------------------------
    Select Case Flag
        Case State.isadd
            Call AddNew
        Case State.isview
            Call SetRight(Flag)
            Call RefreshBill
        Case State.isedit
            Call Edit
    End Select
        
    '取得内容
    Me.Show vbModal
 '   mstate = isView
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'======================================================
' 功  能：根据权限设置工具栏
' 返回值：
' 参  数：无
'======================================================
Private Sub SetRight(ByVal Flag As State)
    With actBar.Bands("tlbMain")
        Select Case Flag
            Case State.isview
                .Tools("tbRefresh").Enabled = Mid(mstrAuth, 1, 1) = "1"
                .Tools("tbAdd").Enabled = Mid(mstrAuth, 2, 1) = "1"
                .Tools("tbEdit").Enabled = Mid(mstrAuth, 3, 1) = "1"
'                .Tools("tbDel").Enabled = Mid(mstrAuth, 4, 1) = "1"
                .Tools("tbCheck").Enabled = Mid(mstrAuth, 5, 1) = "1"
                .Tools("tbPrint").Enabled = Mid(mstrAuth, 6, 1) = "1"
                .Tools("tbAddRow").Enabled = False
                .Tools("tbDelRow").Enabled = False
                .Tools("tbSave").Enabled = False
                .Tools("tbCancel").Enabled = False
                fraBase.Enabled = False
                fraTitle.Enabled = False
                txtBillID.Locked = True
                txtID.Locked = True
                vfgList.Editable = flexEDNone
            Case State.isadd
                .Tools("tbRefresh").Enabled = False
                .Tools("tbAdd").Enabled = False
                .Tools("tbEdit").Enabled = False
'                .Tools("tbDel").Enabled = False
                .Tools("tbCheck").Enabled = False
                .Tools("tbPrint").Enabled = False
                .Tools("tbSave").Enabled = True
                .Tools("tbCancel").Enabled = True
                .Tools("tbAddRow").Enabled = True
                .Tools("tbDelRow").Enabled = True
                fraBase.Enabled = False
                fraTitle.Enabled = False
                txtBillID.Locked = True
                txtID.Locked = True
'                vfgList.Rows = 1
                vfgList.Editable = flexEDKbdMouse
'                vfgList.Rows = 2
'                vfgList.TextMatrix(1, 0) = "1"
            Case State.isedit
                .Tools("tbRefresh").Enabled = False
                .Tools("tbAdd").Enabled = False
                .Tools("tbEdit").Enabled = False
'                .Tools("tbDel").Enabled = False
                .Tools("tbCheck").Enabled = False
                .Tools("tbPrint").Enabled = False
                .Tools("tbSave").Enabled = True
                .Tools("tbCancel").Enabled = True
                .Tools("tbAddRow").Enabled = True
                .Tools("tbDelRow").Enabled = True
                fraBase.Enabled = False
                fraTitle.Enabled = False
                txtBillID.Locked = True
                txtID.Locked = True
                vfgList.Rows = vfgList.Rows + 1
                vfgList.TextMatrix(vfgList.Rows - 1, conID) = vfgList.Rows - 1
                vfgList.Editable = flexEDKbdMouse
        End Select
    End With
End Sub

'初始化下拉框
Private Function InitCbo() As Boolean
On Error GoTo Err
    Dim strSQL          As String
    Dim rstTmp          As ADODB.Recordset

    strSQL = "SELECT * FROM t_GP_Item ORDER BY FClassNumber,FNumber"
    Set rstTmp = GetRecordset(strSQL)
    '来件类型
    rstTmp.Filter = "FClassNumber='4'"
    With vfgCbo(0)
        .ColComboList(0) = .BuildComboList(rstTmp, "FName,FNumber", "FNumber")
    End With
    '紧急度
    rstTmp.Filter = "FClassNumber='5'"
    With vfgCbo(1)
        .ColComboList(0) = .BuildComboList(rstTmp, "FName,FNumber", "FNumber")
    End With
    '密级
    rstTmp.Filter = "FClassNumber='6'"
    With vfgCbo(2)
        .ColComboList(0) = .BuildComboList(rstTmp, "FName,FNumber", "FNumber")
    End With
    InitCbo = True
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'初始化表格
Private Function InitList() As Boolean
    With vfgList
        .Rows = 1
        .Rows = 2
        .TextMatrix(1, 0) = "1"
    End With
End Function


'校验
Private Function CheckData() As Boolean
On Error GoTo Err
    Dim lngI            As Long
    
    
    CheckData = True
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'保存新增
Private Function DoSaveNew() As Boolean
On Error GoTo Err
    Dim lngI            As Long
    Dim FEntryID        As Long
    Dim strSQL          As String
    Dim rstTmp          As ADODB.Recordset
    Dim FID             As String           '业务号
    Dim FBillID         As String           '单号
    Dim strTmp          As String
    Dim dblMoney        As Double
    dblMoney = 0
    If Not CheckData Then Exit Function
        
    FID = Trim(txtID.Text)
    FBillID = Trim(txtBillID.Text)
    FEntryID = 1
    '先生成表体SQL
    With vfgList
        For lngI = 1 To .Rows - 1
            If Len(Trim(.TextMatrix(lngI, conProjectNumber))) > 0 Or Len(Trim(.TextMatrix(lngI, conProjectName))) > 0 Then
                strSQL = strSQL & vbCrLf & _
                        "INSERT INTO t_GP_QYBillEntry(" & _
                        "FID,FBillID,FEntryID,FProjectNumber,FProjectName,FUnit,FQty,FPrice,FMoney)" & _
                        "VALUES('" & _
                        "@FID@" & "','" & "@FBillID@" & "'," & FEntryID & ",'" & Trim(.TextMatrix(lngI, conProjectNumber)) & _
                        "','" & Trim(.TextMatrix(lngI, conProjectName)) & "','" & Trim(.TextMatrix(lngI, conUnit)) & "'," & .ValueMatrix(lngI, conQty) & _
                        "," & .ValueMatrix(lngI, conPrice) & "," & .ValueMatrix(lngI, conMoney) & _
                        ")"
                dblMoney = dblMoney + .ValueMatrix(lngI, conMoney)
                FEntryID = FEntryID + 1
            End If
        Next
    End With
    '无分录退出
    If Len(strSQL) = 0 Then
        MsgBox "没有合法的分录，不允许保存！", vbInformation, gConTitle
        Exit Function
    End If
    '表头SQL
    strSQL = "INSERT INTO t_GP_QYBill(" & _
             "FID,FBillID,FDate,FDept,FContact,FPhone,FType,FName," & _
             "FNo,FDonne,FHurry,FSecret,FIsNo,FState,FPrepare,FSumMoney" & _
             ")VALUES(" & _
             "'@FID@','@FBillID@','" & _
             Format(dtpDate.Value, "yyyy-MM-dd") & "','" & txtDept.Text & "','" & txtContact.Text & "','" & _
             txtTel.Text & "','" & vfgCbo(0).Cell(flexcpTextDisplay, 0, 0) & "','" & txtName.Text & "','" & txtNo.Text & "','" & _
             txtDonne.Text & "','" & vfgCbo(1).Cell(flexcpTextDisplay, 0, 0) & "','" & vfgCbo(2).Cell(flexcpTextDisplay, 0, 0) & "'," & chkIsNo.Value & _
             ",1,'" & txtPrepare.Text & "'," & dblMoney & ")" & strSQL
    '开始事务
    glngLevel = gConn.BeginTrans
    strTmp = "SELECT * FROM t_GP_QYBill WHERE FBillID='" & FBillID & "'"
    Set rstTmp = GetRecordset(strTmp)
    
    '单据号重复,自动更新单据号
    If rstTmp.RecordCount > 0 Then _
        FBillID = AutoID("t_GP_QYBill", "FBillID", "QY")
    
    strTmp = "SELECT * FROM t_GP_QYBill WHERE FID='" & FID & "'"
    Set rstTmp = GetRecordset(strTmp)
    
    '业务号重复，自动更新业务号
    If rstTmp.RecordCount > 0 Then _
        FID = AutoID("t_GP_QYBill", "FID")
        
    strSQL = Replace(strSQL, "@FID@", FID)
    strSQL = Replace(strSQL, "@FBillID@", FBillID)
    gConn.Execute strSQL
    gConn.CommitTrans
    glngLevel = 0
    mBillID = FBillID
    mstate = isview
    Call RefreshBill
    Call SetRight(isview)
    DoSaveNew = True
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'保存修改
Private Function DoSaveEdit() As Boolean
On Error GoTo Err
    Dim lngI            As Long
    Dim FEntryID        As Long
    Dim strSQL          As String
    Dim rstTmp          As ADODB.Recordset
    Dim FID             As String           '业务号
    Dim FBillID         As String           '单号
    Dim strTmp          As String
    Dim dblMoney        As Double
    
    If Not CheckData Then Exit Function
        
    FID = Trim(txtID.Text)
    FBillID = Trim(txtBillID.Text)
    FEntryID = 1
    '先生成表体SQL
    With vfgList
        For lngI = 1 To .Rows - 1
            If Len(Trim(.TextMatrix(lngI, conProjectNumber))) > 0 Or Len(Trim(.TextMatrix(lngI, conProjectName))) > 0 Then
                strSQL = strSQL & vbCrLf & _
                        "INSERT INTO t_GP_QYBillEntry(" & _
                        "FID,FBillID,FEntryID,FProjectNumber,FProjectName,FUnit,FQty,FPrice,FMoney)" & _
                        "VALUES('" & _
                        "@FID@" & "','" & "@FBillID@" & "'," & FEntryID & ",'" & Trim(.TextMatrix(lngI, conProjectNumber)) & _
                        "','" & Trim(.TextMatrix(lngI, conProjectName)) & "','" & Trim(.TextMatrix(lngI, conUnit)) & "'," & .ValueMatrix(lngI, conQty) & _
                        "," & .ValueMatrix(lngI, conPrice) & "," & .ValueMatrix(lngI, conMoney) & _
                        ")"
                dblMoney = dblMoney + .ValueMatrix(lngI, conMoney)
                FEntryID = FEntryID + 1
            End If
        Next
    End With
    '无分录退出
    If Len(strSQL) = 0 Then
        MsgBox "没有合法的分录，不允许保存！", vbInformation, gConTitle
        Exit Function
    End If
    '表头SQL,先删除再插入
    strSQL = "DELETE FROM t_GP_QYBillEntry WHERE FBillID='" & FBillID & "'" & vbCrLf & _
             "DELETE FROM t_GP_QYBill WHERE FBillID='" & FBillID & "'" & vbCrLf & _
             "INSERT INTO t_GP_QYBill(" & _
             "FID,FBillID,FDate,FDept,FContact,FPhone,FType,FName," & _
             "FNo,FDonne,FHurry,FSecret,FIsNo,FState,FPrepare,FSumMoney" & _
             ")VALUES(" & _
             "'@FID@','@FBillID@','" & _
             Format(dtpDate.Value, "yyyy-MM-dd") & "','" & txtDept.Text & "','" & txtContact.Text & "','" & _
             txtTel.Text & "','" & vfgCbo(0).Cell(flexcpTextDisplay, 0, 0) & "','" & txtName.Text & "','" & txtNo.Text & "','" & _
             txtDonne.Text & "','" & vfgCbo(1).Cell(flexcpTextDisplay, 0, 0) & "','" & vfgCbo(2).Cell(flexcpTextDisplay, 0, 0) & "'," & chkIsNo.Value & _
             ",1,'" & txtPrepare.Text & "'," & dblMoney & ")" & strSQL
    '开始事务
    glngLevel = gConn.BeginTrans
    strTmp = "SELECT * FROM t_GP_QYBill WHERE FBillID='" & FBillID & "'"
    Set rstTmp = GetRecordset(strTmp)
    If rstTmp.RecordCount = 0 Then
        MsgBox "单据【" & FBillID & "】已被删除,不允许保存，请刷新数据查看！", vbInformation, gConTitle
        gConn.RollbackTrans
        glngLevel = 0
        Exit Function
    End If
    
    If Trim(rstTmp!FCheck & "") <> "" Then
        MsgBox "单据【" & FBillID & "】已被审核,不允许保存，请刷新数据查看！", vbInformation, gConTitle
        gConn.RollbackTrans
        glngLevel = 0
        Exit Function
    End If
    strSQL = Replace(strSQL, "@FID@", FID)
    strSQL = Replace(strSQL, "@FBillID@", FBillID)
    gConn.Execute strSQL
    gConn.CommitTrans
    glngLevel = 0
    mBillID = FBillID
    mstate = isview
    Call RefreshBill
    Call SetRight(isview)
    DoSaveEdit = True
    Exit Function
Err:
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'显示单据
Private Function RefreshBill() As Boolean
On Error GoTo Err
    Dim strSQL      As String
    Dim rstTmp      As ADODB.Recordset
    Dim lngI        As Long
    
    fraBase.Enabled = False
    fraTitle.Enabled = False
    vfgList.Editable = flexEDNone
    Call InitList
    strSQL = "SELECT * FROM t_GP_QYBill WHERE FBillID='" & mBillID & "'"
    Set rstTmp = GetRecordset(strSQL)
    If rstTmp.RecordCount = 0 Then
        MsgBox "没有单据【" & mBillID & "】。可能已被删除！", vbInformation, gConTitle
        Set rstTmp = Nothing
        Exit Function
    End If
    '显示表头
    With rstTmp
        txtBillID.Text = !FBillID
        txtID.Text = !FID
        dtpDate.Value = !FDate
        txtDept.Text = !FDept
        txtContact.Text = !FContact
        txtTel.Text = !FPhone
        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)
        txtCheck.Text = !FCheck
        txtPrepare.Text = !FPrepare
        txtState.Text = GetState(!FState)
    End With
    
    strSQL = "SELECT * FROM t_GP_QYBillEntry WHERE FBillID='" & mBillID & "' ORDER BY FEntryID"
    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) = rstTmp!FEntryID
                .TextMatrix(lngI, conProjectNumber) = rstTmp!FProjectNumber
                .TextMatrix(lngI, conProjectName) = rstTmp!FProjectName
                .TextMatrix(lngI, conQty) = rstTmp!FQty
                .TextMatrix(lngI, conUnit) = rstTmp!FUnit
                .TextMatrix(lngI, conPrice) = rstTmp!FPrice
                .TextMatrix(lngI, conMoney) = rstTmp!FMoney
                rstTmp.MoveNext
            Next
        End With
    End If
    Set rstTmp = Nothing
    RefreshBill = True
    Exit Function
Err:
    Set rstTmp = Nothing
    Call ErrTreat(Err.Number, Err.Source, Err.Description)
End Function

'修改
Private Function Edit() As Boolean
On Error GoTo Err
    Dim strSQL      As String
    Dim rstTmp      As ADODB.Recordset
    If Not mstate = isview Then
        If mBillID <> "" Then RefreshBill
    End If
    
    strSQL = "SELECT FCheck FROM t_GP_QYBill WHERE FBillID='" & mBillID & "'"
    glngLevel = gConn.BeginTrans
    Set rstTmp = GetRecordset(strSQL)
    If rstTmp.RecordCount = 0 Then
        gConn.RollbackTrans
        glngLevel = 0
        Set rstTmp = Nothing