VB开发的ERP系统

                .Buttons("Quit").Enabled = True
            End With
            With Me.SSTab_Formula
                .Tab = 0
                .TabEnabled(0) = True
                .TabEnabled(1) = False
            End With
            Me.ImgCmb_Sort.Enabled = True
            Me.GsToolbar.Enabled = True
            
        Case STATUS_ADD '增加
            With Me.TB_Function
                .Buttons("Add").Enabled = False
                .Buttons("Edit").Enabled = False
                .Buttons("Del").Enabled = False
                .Buttons("Save").Enabled = False
                .Buttons("Refresh").Enabled = False
                .Buttons("Help").Enabled = True
                .Buttons("Quit").Enabled = True
            End With
            With Me.SSTab_Formula
                .Tab = 1
                .TabEnabled(1) = True
                .TabEnabled(0) = False
                Me.Txt_Field.Enabled = True
                Me.Cmd_SelectField.Enabled = True
            End With
            With Me
                .ImgCmb_Sort.Enabled = False
                .Txt_Field.Text = ""
                .Txt_Field.Tag = ""
                .Txt_FContent = ""
                .Txt_FLimit = ""
            End With
            Me.GsToolbar.Enabled = False
        Case STATUS_EDIT '修改
            With Me.TB_Function
                .Buttons("Add").Enabled = False
                .Buttons("Edit").Enabled = False
                .Buttons("Del").Enabled = False
                .Buttons("Save").Enabled = False
                .Buttons("Refresh").Enabled = False
                .Buttons("Help").Enabled = True
                .Buttons("Quit").Enabled = True
            End With
            With Me.SSTab_Formula
                .Tab = 1
                .TabEnabled(1) = True
                .TabEnabled(0) = False
                Me.Txt_Field.Enabled = False
                Me.Cmd_SelectField.Enabled = False
            End With
            Me.ImgCmb_Sort.Enabled = False
            Me.GsToolbar.Enabled = False
    End Select
    iNowState = iStatus
End Function

Private Sub Cmd_Save_Click() '保存
    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
    If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
        Exit Sub
    End If
    
    With Me.vsFG_Formula
        If .Rows > .FixedRows Then
            Save
        End If
    End With
End Sub

Private Sub Cmd_SelectField_Click() '显示字段帮助
    Dim frm As New XT_TybmczFrm
    Xtbmczdm = "Pm_FormulaField"
    frm.sParamater = GetComboKey(Me.ImgCmb_Sort, 0) '自己加入的变量,用来增加条件
    frm.Show 1
    Me.Txt_Field.Text = Xtfhcsfz
    Me.Txt_Field.Tag = Xtfhcs
    Set frm = Nothing
End Sub

Private Sub Cmd_Up_Click()
    CmdUP Me.vsFG_Formula
End Sub


Private Sub Form_KeyUp(KeyCode As Integer, Shift As Integer)        '支持热键操作

    If Shift = 2 Then
        Select Case UCase(Chr(KeyCode))
            Case "P"                                                                          'Ctrl+P 打印
                If TB_Function.Buttons("dy").Visible And TB_Function.Buttons("dy").Enabled Then
                    Call TB_Function_ButtonClick(Me.TB_Function.Buttons("dy"))
                End If
            Case "A"                                                                          'Ctrl+A 增加
                '判断用户是否有此功能执行权限,如有则写上机日志(进入)
                If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                    Exit Sub
                End If
                If TB_Function.Buttons("Add").Visible And TB_Function.Buttons("Add").Enabled Then
                   Call TB_Function_ButtonClick(Me.TB_Function.Buttons("Add"))
                End If
            Case "D"                                                                          'Ctrl+D 删除
                If TB_Function.Buttons("Del").Visible And TB_Function.Buttons("Del").Enabled Then
                    Call TB_Function_ButtonClick(Me.TB_Function.Buttons("Del"))
                End If
        End Select
    End If
    
End Sub



Private Sub Form_Load()
    On Error GoTo ErrCtrl
    
    iNowState = 0
    Dim s As String
    Dim rs As New ADODB.Recordset
    Dim itm As ComboItem
        '调入打印页面设置窗体
    ReportTitle = "公式定义"
    XtReportCode = "PM_Formula"
    Load Dyymctbl
    
    '调 入 网 格(Fixed)
    GridCode = "PM_Formula"
    Call BzWgcsh(Me.vsFG_Formula, GridCode, GridInf(), GridBoolean(), GridInt(), GridStr())
    Qslz = GridInf(1)
    Sjhgd = GridInf(2)
    Sfxshjwg = GridInf(7)
    Szzls = Me.vsFG_Formula.Cols - 1
    
    '填充工资类别
    s = "SELECT DISTINCT b.SortID,b.SortName FROM PM_OpeSort a INNER JOIN PM_Sort b on a.SortID=b.SortID WHERE a.Czybm='" & Xtczybm & "'"
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
       Do While Not .EOF()
           Set itm = Me.ImgCmb_Sort.ComboItems.Add(, "@" & Trim(!SortId), Trim(!SortName))
           itm.Tag = !SortId
           .MoveNext
       Loop
       .Close
    End With
    Set rs = Nothing
    Set itm = Nothing
    With Me.ImgCmb_Sort
        If .ComboItems.Count > 0 Then
            .ComboItems(1).Selected = True
        End If
    End With
    
    InitView Me.TV_PreField, " FieldType<>0 " '填充字段树
    RefreshGrid '刷新网格内容
    ChangeStatus STATUS_VIEW    '改变工具栏状态
    '编辑(新增、修改、删除)权限索引
    Str_RightEdit = "Pm_Formula_edit"
    Exit Sub
    
ErrCtrl:
    If rs.State = 1 Then
        rs.Close
    End If
    Set rs = Nothing
    Set itm = Nothing
    Unload Me
End Sub

Private Function Add() '改变为新增状态
    ChangeStatus STATUS_ADD
End Function

Private Function Edit(iPos As Integer) '修改iPos行的记录
    On Error Resume Next
    Dim s As String
    Dim rs As New ADODB.Recordset
    s = "SELECT  a.*,b.ChName as FieldNameC from PM_Formula a " & Chr(10) _
        & " INNER JOIN Rs_Items b on a.FieldName=b.FieldName " & Chr(10) _
        & " WHERE FCode=" & Me.vsFG_Formula.TextMatrix(iPos, 0)
    Set rs = Cw_DataEnvi.DataConnect.Execute(s)
    With rs
        If .EOF() Then
            MsgBox "此公式已经被删除,不能够修改!", vbOKOnly + vbCritical
            Exit Function
        End If
        Me.Txt_Field.Tag = Trim(!FieldName & "")
        Me.Txt_Field.Text = Trim(!FieldNameC & "")
        Me.Txt_FContent.Text = Trim(!FContentUser & "")
        Me.Txt_FLimit.Text = Trim(!FLimitUser & "")
        Me.Chk_Valid.Value = !FIsUsed
    End With
    ChangeStatus STATUS_EDIT
End Function

Private Function Del(iPos As Integer) '删除iPos行的记录
    On Error GoTo ErrCtrl
    Dim s As String
    If MsgBox("确定要删除当前公式吗?", vbOKCancel + vbQuestion) = vbOK Then
        s = "DELETE From PM_Formula WHERE FCode=" & Me.vsFG_Formula.TextMatrix(iPos, 0)
        Cw_DataEnvi.DataConnect.Execute (s)
        Me.vsFG_Formula.RemoveItem (iPos)
    End If
    Exit Function
    
ErrCtrl:
    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 GsToolbar_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case Button.Key
      Case "bcgs"                              '保存表格格式
        Call Bcwggs(Me.vsFG_Formula, GridCode, GridStr())
      Case "hfmrgs"                            '恢复默认格式
        Call Hfmrgs(Me.vsFG_Formula, GridCode, GridStr())
      Case "szxsxm"                            '设置显示项目
        Call Szxsxm(Me.vsFG_Formula, GridCode)
    End Select
End Sub

Private Sub ImgCmb_Sort_Click()
    RefreshGrid
End Sub

Private Sub Opt_AddType_Click(Index As Integer) '根据不同状态填充不同字段
    If Me.Opt_AddType(0).Value = True Then
        InitView Me.TV_PreField, " FieldType<>0 "
    Else
        InitView Me.TV_PreField
    End If
End Sub

Private Sub TB_Function_ButtonClick(ByVal Button As MSComctlLib.Button)
    Select Case UCase(Button.Key)
        Case UCase("ymsz")                                          '页面设置
            Dyymctbl.Show 1
        Case UCase("yl")                                            '预 览
            Call bbyl(True)
        Case UCase("dy")                                            '打 印
            Call bbyl(False)
        Case UCase("Add") '增加
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                Exit Sub
            End If
            Add
        Case UCase("Edit") '修改
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True, False) Then
                Cmd_OK.Enabled = False
            End If
            With Me.vsFG_Formula
                If .Row >= .FixedRows Then
                    Edit .Row
                End If
            End With
        Case UCase("Save") '保存
            With Me.vsFG_Formula
                If .Rows > .FixedRows Then
                    Save
                End If
            End With
        Case UCase("Del") '删除
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log(Str_RightEdit, Xtczybm, 1, True) Then
                 Exit Sub
            End If
            With Me.vsFG_Formula
                If .Row >= .FixedRows Then
                    Del .Row
                End If
            End With
        Case UCase("Refresh") '刷新
            RefreshGrid
        Case UCase("Help") '帮助
            Call F1bz
        Case UCase("Quit") '退出
            Unload Me
    End Select
End Sub

Private Sub TV_FieldValue_BeforeLabelEdit(Cancel As Integer)
    '防止用户修改树的值
    Cancel = 1
End Sub

Private Sub TV_FieldValue_NodeClick(ByVal Node As MSComctlLib.Node) '添加字段到相应位置
    Dim nod As Node
    With Me.TV_FieldValue
        Set nod = .SelectedItem
        '如果没有选中节点
        If nod Is Nothing Then
            Exit Sub
        End If
        '如果节点是根结点
        If nod.Parent Is Nothing Then
            Set nod = Nothing
            Exit Sub
        End If
        Me.Txt_FLimit.Text = Me.Txt_FLimit.Text & " " & nod.Text
    End With
    Set nod = Nothing
End Sub

Private Sub TV_PreField_BeforeLabelEdit(Cancel As Integer)
    '防止用户修改树的值
    Cancel = 1
End Sub

Private Sub TV_PreField_DblClick() '添加此字段到相应位置
    Dim nod As Node
    With Me.TV_PreField
        '如果当前没有选中接点,退出
        Set nod = .SelectedItem
        If nod Is Nothing Then
            Exit Sub
        End If
        '如果不是字段.退出
        If nod.Children <> 0 Then
            Set nod = Nothing
            Exit Sub
        End If
        '如果是根结点,推出
        If nod.Parent Is Nothing Then
            Exit Sub
        End If
        '添加节点到相应位置
        If Me.Opt_AddType(0).Value = True Then
            Me.Txt_FContent.Text = Me.Txt_FContent.Text & " " & nod.Parent.Text & "." & nod.Text
        Else
            Me.Txt_FLimit.Text = Me.Txt_FLimit.Text & " " & nod.Parent.Text & "." & nod.Text
        End If
    End With
    '如果当前节点有相关帮助,并且不是上一次选中的节点,填充相关帮助
    If sFieldOld <> nod.Key Then
        FillValue2TV nod.Tag, Me.TV_FieldValue
        sFieldOld = nod.Key
    End If
    Set nod = Nothing
End Sub


Private Sub Txt_Field_KeyDown(KeyCode As Integer, Shift As Integer)
    If KeyCode = 113 Then   '帮助F2
        Call Cmd_SelectField_Click
    End If
End Sub

Private Sub vsFG_Formula_DblClick()
    '调用编辑公式过程
    Call TB_Function_ButtonClick(Me.TB_Function.Buttons("Edit"))
End Sub

Private Sub bbyl(bbylte As Boolean)                    '报表打印预览

    Dim Bbzbt$, Bbxbt() As String, bbxbtzzxs() As Integer, Bbxbtgs As Integer
    Dim Bbbwh() As String, Bbbwhzzxs() As Integer, Bbbwhgs As Integer
    Bbxbtgs = 2                                          '报 表 小 标 题 行 数
    Bbbwhgs = 0                                          '报 表 表 尾 行 数
    ReDim Bbxbt(1 To Bbxbtgs)
    ReDim bbxbtzzxs(1 To Bbxbtgs)
    
    If Bbbwhgs <> 0 Then
        ReDim Bbbwh(1 To Bbbwhgs)
        ReDim Bbbwhzzxs(1 To Bbbwhgs)
    End If
    
    Bbzbt = ReportTitle
    Bbxbt(1) = " "
    Bbxbt(2) = "工资类别:" & Me.ImgCmb_Sort.Text
    bbxbtzzxs(1) = 0                                     '报表行组织形式(0-居左 1-居中 2-居右)
    
    Call Scyxsjb(Me.vsFG_Formula)                                '生成报表数据
    Call Scdybb(Dyymctbl, Bbzbt, Bbxbt(), bbxbtzzxs(), Bbxbtgs, Bbbwh(), Bbbwhzzxs(), Bbbwhgs, bbylte)
  
    If Not bbylte Then
        Unload DY_Tybbyldy
    End If
    
End Sub