VB开发的ERP系统

'******************************************************************
'*    模 块 名 称 :公式定义
'*    功 能 描 述 :
'*    程序员姓名  :苗鹏
'*    最后修改人  :苗鹏
'*    最后修改时间:2002/01/01
'*    备        注:主要公式操作验证工作在CQuery类中完成
'******************************************************************

Const STATUS_VIEW As Integer = 0        '浏览状态
Const STATUS_ADD As Integer = 1         '增加状态
Const STATUS_EDIT As Integer = 2        '编辑状态

Dim sFieldOld As String                 '前一个相关的字段名
Dim iNowState As Integer                '现在的状态
Dim Str_RightEdit As String              '编辑(新增、修改、删除)权限索引

'以下为固定使用变量
Dim ReportTitle As String
Dim Dyymctbl As New DY_Dyymsz            '打印页面窗体变量
Dim GridCode As String                   '显示网格网格代码
Dim GridInf() As Variant                 '整个网格设置信息
Dim Tsxx As String                       '系统提示信息
Dim Qslz As Long                         '网格隐藏(非操作显示)列数
Dim Sjhgd As Double                      '网格数据行高度
Dim Sfxshjwg As Boolean                  '是否显示合计网格
Dim GridBoolean() As Boolean             '网格列信息(布尔型)
Dim GridStr()  As String                 '网格列信息(字符型)
Dim GridInt() As Integer                 '网格列信息(整型)
Dim Szzls As Integer                     '数组总列数(网格列数-1)

Private Sub Cmd_Cancel_Click()  '取消公式定义
    '改变状态
    ChangeStatus STATUS_VIEW
End Sub

Private Function RefreshGrid() '刷新网格
    On Error GoTo ErrCtrl
    
    Dim s As String
    Dim sSortID As String
    Dim rs As New ADODB.Recordset
    '清空数据
    Me.vsFG_Formula.Rows = Me.vsFG_Formula.FixedRows
    '读取工资类别
    sSortID = GetComboKey(Me.ImgCmb_Sort, 0)
    '填充数据
    s = "SELECT  a.*,b.ChName as FieldNameC from PM_Formula a INNER JOIN Rs_Items b on a.FieldName=b.FieldName WHERE a.SortID='" & sSortID & "' ORDER BY a.FOrder "
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    
    With Me.vsFG_Formula
        .Redraw = False
            Do While Not rs.EOF()
                .AddItem ""
                .RowHeight(.Rows - 1) = Sjhgd
                .TextMatrix(.Rows - 1, 0) = Trim(rs!FCode & "")
                .TextMatrix(.Rows - 1, Sydz("001", GridStr(), Szzls)) = .Rows - .FixedRows              '编号
                .TextMatrix(.Rows - 1, Sydz("002", GridStr(), Szzls)) = Trim(rs!FieldNameC & "")        '汉语名称
                .TextMatrix(.Rows - 1, Sydz("003", GridStr(), Szzls)) = Trim(rs!FContentUser & "")      '用户公式条件
                .TextMatrix(.Rows - 1, Sydz("004", GridStr(), Szzls)) = Trim(rs!FLimitUser & "")        '用户限定条件
                .TextMatrix(.Rows - 1, Sydz("005", GridStr(), Szzls)) = rs!FIsUsed                      '是否可用
                rs.MoveNext
            Loop
        .Redraw = True
        .Refresh
    End With
    Set rs = Nothing
    Exit Function
    
ErrCtrl:
    Set rs = Nothing
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function

Private Sub Cmd_Change_Click() '交换数字和操作符
    
    With Me.Fm_Number
        If Trim(.Caption) = "数字符号:" Then
            Cmd_Number(0).Caption = " +"
            Cmd_Number(1).Caption = " -"
            Cmd_Number(2).Caption = " *"
            Cmd_Number(3).Caption = " /"
            Cmd_Number(4).Caption = " ="
            Cmd_Number(5).Caption = " <>"
            Cmd_Number(6).Caption = " >"
            Cmd_Number(7).Caption = " >="
            Cmd_Number(8).Caption = " <"
            Cmd_Number(9).Caption = " <="
            Cmd_Number(10).Caption = " ("
            Cmd_Number(11).Caption = " )"
            Cmd_Number(12).Caption = " OR"
            .Caption = "运算符号:"
        Else
            Cmd_Number(0).Caption = "1"
            Cmd_Number(1).Caption = "2"
            Cmd_Number(2).Caption = "3"
            Cmd_Number(3).Caption = "4"
            Cmd_Number(4).Caption = "5"
            Cmd_Number(5).Caption = "6"
            Cmd_Number(6).Caption = "7"
            Cmd_Number(7).Caption = "8"
            Cmd_Number(8).Caption = "9"
            Cmd_Number(9).Caption = "0"
            Cmd_Number(10).Caption = "%"
            Cmd_Number(11).Caption = "."
            Cmd_Number(12).Caption = " AND"
            .Caption = "数字符号:"
        End If
    End With
End Sub

Private Sub Cmd_Down_Click() '当前公式顺序下移
    CmdDown Me.vsFG_Formula
End Sub

Private Sub Cmd_Guide_Click() '显示公式向导
    
    Dim s As String
    Dim frm As New Formula_Guide_Frm
    '显示公式向导
    With frm
        .Show 1
        s = .sFunction
    End With
    
    '向文本框中添加函数
    If s <> "" Then
        If Me.Opt_AddType(0).Value = True Then
            '添加公式
            With Me.Txt_FContent
                If .SelLength <> 0 Then
                    .Text = ReplByPos(.Text, s, .SelStart + 1, .SelStart + .SelLength + 1)
                Else
                    .Text = .Text & " " & s
                End If
            End With
        Else
            '添加限定条件
            With Me.Txt_FLimit
                If .SelLength <> 0 Then
                    .Text = ReplByPos(.Text, s, .SelStart + 1, .SelStart + .SelLength + 1)
                Else
                    .Text = .Text & " " & s
                End If
            End With
        End If
    End If
    Set frm = Nothing
End Sub

Private Sub Cmd_Number_Click(Index As Integer) '向本框中添加数字或操作符
    Dim s As String
    s = Me.Cmd_Number(Index).Caption
    If Me.Opt_AddType(0).Value = True Then
'        添加公式
        With Me.Txt_FContent
            If .SelLength <> 0 Then
                .Text = ReplByPos(.Text, s, .SelStart + 1, .SelStart + .SelLength + 1)
            Else
                .Text = .Text & s
            End If
        End With
    Else
'        添加限定条件
        With Me.Txt_FLimit
            If .SelLength <> 0 Then
                .Text = ReplByPos(.Text, s, .SelStart + 1, .SelStart + .SelLength + 1)
            Else
                .Text = .Text & s
            End If
        End With
    End If
End Sub

Private Sub Cmd_OK_Click() '验证并保存公式
    On Error GoTo ErrCtrl
    
    Dim sSortID As String
    Dim s As String
    Dim sSQLFormula As String
    Dim sSqlWhere As String
    Dim cQuerys As New CQuery
    Dim iCode As Integer
    Dim rs As New ADODB.Recordset
    
    '验证字段合法性
    With Me.Txt_Field
        If Trim(.Text) = "" Then
            MsgBox "请录入公式的项目!", vbOKOnly + vbCritical
            If .Enabled = True Then
                .SetFocus
            End If
            Exit Sub
        End If
        s = "SELECT b.FieldName as TCode,b.ChName as TName FROM PM_SortItem a " & Chr(10) _
            & " INNER JOIN Rs_Items b ON a.ItemID=b.ItemID " & Chr(10) _
            & " WHERE a.HaltFlag=0 and a.SortID='" & GetComboKey(Me.ImgCmb_Sort, 0) & "' and (b.FieldName='" & Trim(.Text) & "' or b.ChName='" & Trim(.Text) & "')"
        Set rs = Cw_DataEnvi.DataConnect.Execute(s)
        If rs.EOF() Then
            Set rs = Nothing
            MsgBox "公式项目错误!", vbOKOnly + vbCritical
            Exit Sub
        Else
            .Text = Trim(rs!TName)
            .Tag = Trim(rs!TCode)
        End If
        rs.Close
    End With
    
    '验证公式的正确性
    Set cQuerys.PB_CheckStatus = Me.PB_CheckStatus
    If cQuerys.CheckFormula(Trim(Me.Txt_FContent.Text), "PM_PayRoll." & Trim(Me.Txt_Field.Tag)) = True Then
        sSQLFormula = cQuerys.FormulaSQL
        Me.Txt_FContent.Text = cQuerys.FormulaOld
    Else
        Exit Sub
    End If
    
    '验证限定条件
    If cQuerys.CheckFormula(Trim(Me.Txt_FLimit.Text)) = True Then
        sSqlWhere = cQuerys.FormulaSQL
        Me.Txt_FLimit.Text = cQuerys.FormulaOld
    Else
        Exit Sub
    End If
    
    '更新数据库和列表
    sSortID = GetComboKey(Me.ImgCmb_Sort, 0)
    With Me.vsFG_Formula
        If .Row < .FixedRows Then
            iCode = .FixedRows
        Else
            iCode = .TextMatrix(.Row, 0)
        End If
    End With
    
    If iNowState = STATUS_ADD Then '增加
        s = "SELECT * FROM PM_Formula WHERE 1=2"
        rs.Open s, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
        '添加数据表
        With rs
            .AddNew
            !SortId = sSortID       '工资类别
            !FieldName = Trim(Me.Txt_Field.Tag)     '公式名称
            !FContent = sSQLFormula     '公式内容
            !FLimit = sSqlWhere     '公式限定条件
            !FContentUser = Trim(Me.Txt_FContent.Text)      '公式用户内容
            !FLimitUser = Trim(Me.Txt_FLimit.Text)      '用户限定条件
            !FOrder = 10000     '公式顺序
            !FIsUsed = Me.Chk_Valid.Value       '是否可用
            .Update
        End With
        '添加网格
        With Me.vsFG_Formula
            .AddItem ""
            .TextMatrix(.Rows - 1, 0) = rs!FCode        '编码
            .TextMatrix(.Rows - 1, Sydz("001", GridStr(), Szzls)) = .Rows - .FixedRows      '编号
            .TextMatrix(.Rows - 1, Sydz("002", GridStr(), Szzls)) = Me.Txt_Field.Text       '公式名称
            .TextMatrix(.Rows - 1, Sydz("003", GridStr(), Szzls)) = Me.Txt_FContent.Text    '公式内容
            .TextMatrix(.Rows - 1, Sydz("004", GridStr(), Szzls)) = Me.Txt_FLimit.Text      '公式限定条件
            .TextMatrix(.Rows - 1, Sydz("005", GridStr(), Szzls)) = Me.Chk_Valid.Value      '是否可用
        End With
    Else '修改
        s = "SELECT * FROM PM_Formula WHERE FCode=" & iCode
        rs.Open s, Cw_DataEnvi.DataConnect, adOpenDynamic, adLockPessimistic
        '修改数据表
        With rs
            !FContent = sSQLFormula     '公式内容
            !FLimit = sSqlWhere     '限定条件
            !FContentUser = Trim(Me.Txt_FContent.Text)      '用户内容
            !FLimitUser = Trim(Me.Txt_FLimit.Text)          '用户限定条件
            !FIsUsed = Me.Chk_Valid.Value       '是否可用
            .Update
        End With
        '修改网格内容
        With Me.vsFG_Formula
            .TextMatrix(.Row, Sydz("002", GridStr(), Szzls)) = Me.Txt_Field.Text        '名称
            .TextMatrix(.Row, Sydz("003", GridStr(), Szzls)) = Me.Txt_FContent.Text     '公式内容
            .TextMatrix(.Row, Sydz("004", GridStr(), Szzls)) = Me.Txt_FLimit.Text       '限定条件
            .TextMatrix(.Row, Sydz("005", GridStr(), Szzls)) = Me.Chk_Valid.Value       '是否可用
        End With
    End If
    
    Set rs = Nothing
    Set cQuerys = Nothing
    MsgBox "公式验证通过,并保存成功!", vbOKOnly + vbInformation
    If iNowState = STATUS_ADD Then
        With Me
            .Txt_Field.Text = ""
            .TV_PreField.Tag = ""
            .Txt_FContent = ""
            .Txt_FLimit = ""
        End With
    End If
    Exit Sub
    
ErrCtrl:
    Set rs = Nothing
    Set cQuerys = Nothing
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Sub

Public Function CmdUP(CzxsGrid As VSFlexGrid) '将网格中选定的行向上移一行
    Dim Temp As String
    Dim j As Long
    With CzxsGrid
        If .Rows = .FixedRows Then
            Exit Function
        End If
        If .Row <> .FixedRows Then
            For j = 0 To .Cols - 1
                Temp = .TextMatrix(.Row - 1, j)
                .TextMatrix(.Row - 1, j) = .TextMatrix(.Row, j)
                .TextMatrix(.Row, j) = Temp
            Next
            .Row = .Row - 1
        End If
    End With
End Function

Public Function CmdDown(CzxsGrid As VSFlexGrid) '将网格中选定的行向下移一行
    Dim Temp As String
    Dim j As Long
    With CzxsGrid
        If .Rows = .FixedRows Then
            Exit Function
        End If
        If .Row <> .Rows - 1 Then
            For j = 0 To .Cols - 1
                Temp = .TextMatrix(.Row + 1, j)
                .TextMatrix(.Row + 1, j) = .TextMatrix(.Row, j)
                .TextMatrix(.Row, j) = Temp
            Next
            .Row = .Row + 1
        End If
    End With
End Function

Private Function Save() '根据当前网格公式顺序修改数据库公式顺序
    On Error GoTo ErrCtrl
    
    Dim bBeginTrans As Boolean
    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim i As Integer
    '生成Sql语句
    With Me.vsFG_Formula
        For i = .FixedRows To .Rows - 1
            s = s & "UPDATE PM_Formula SET FOrder =" & i & " WHERE FCode= " & .TextMatrix(i, 0) & Chr(13)
        Next i
    End With
    Cw_DataEnvi.DataConnect.BeginTrans
        bBeginTrans = True
        Cw_DataEnvi.DataConnect.Execute s
    Cw_DataEnvi.DataConnect.CommitTrans
    MsgBox "公式顺序保存成功!", vbOKOnly + vbInformation
    Exit Function
    
ErrCtrl:
    If bBeginTrans = True Then
        Cw_DataEnvi.DataConnect.RollbackTrans
    End If
    Dim smsg As String
    Dim smsgSys As String
    smsg = GetError(Err.Number)
    smsgSys = Err.Number & Err.Description & "!"
    MsgBox IIf(smsg = "", smsgSys, smsg), vbOKOnly + vbCritical
End Function

Private Function ChangeStatus(iStatus As Integer) '改变窗体状态 iStatus=0 浏览 1新增 2 修改
    Select Case iStatus
        Case STATUS_VIEW '浏览
            With Me.TB_Function
                .Buttons("Add").Enabled = True
                .Buttons("Edit").Enabled = True
                .Buttons("Del").Enabled = True
                .Buttons("Save").Enabled = True
                .Buttons("Refresh").Enabled = True
                .Buttons("Help").Enabled = True