VB开发的ERP系统

Private Sub tvTreeView_NodeClick(ByVal Node As MSComctlLib.Node)
    Dim Ssql As String
    If Node.Tag <> "" Then
        If Node.Tag = False Then
            Ssql = "SELECT * FROM xt_xtgnb where sjgnbm='" + Mid(Trim(tvTreeView.SelectedItem.Key), 2, Len(Trim(tvTreeView.SelectedItem.Key)) - 1) + "' and MenuList=1 order by gnbm"
            If sjgnbmStr = Mid(Trim(tvTreeView.SelectedItem.Key), 2, Len(Trim(tvTreeView.SelectedItem.Key)) - 1) Then
                Exit Sub
            Else
                sjgnbmStr = Mid(Trim(tvTreeView.SelectedItem.Key), 2, Len(Trim(tvTreeView.SelectedItem.Key)) - 1)
            End If
        Else
            Ssql = "SELECT * FROM xt_xtgnb a," _
                    & "(SELECT sjgnbm FROM xt_xtgnb where gnbm='" + Mid(Trim(tvTreeView.SelectedItem.Key), 2, Len(Trim(tvTreeView.SelectedItem.Key)) - 1) + "')b" & " where a.sjgnbm=b.sjgnbm and MenuList=1 order by gnbm"
        End If
        
        Set Xtgnbrec = Cw_DataEnvi.DataConnect.Execute(Ssql)
        If Node.Tag = True Then
            If sjgnbmStr = Trim(Xtgnbrec!sjgnbm) Then
                Exit Sub
            Else
                sjgnbmStr = Trim(Xtgnbrec!sjgnbm)
            End If
        End If
        lvListView.ColumnHeaders.Clear
        lvListView.ListItems.Clear
        lvListView.ColumnHeaders.Add 1, "rcsw", "明细", 3000, , "stb"
        Do While Not Xtgnbrec.EOF
            Set mitem = lvListView.ListItems.Add()
            mitem.Text = Trim(Xtgnbrec!gnmc)
            If Xtgnbrec.Fields("mjbz") Then
                mitem.SmallIcon = "gnqx"
                mitem.Icon = "y"
            Else
                mitem.Icon = "i"
                mitem.SmallIcon = "stb"
            End If
            mitem.Key = "T" & Trim(Xtgnbrec!gnbm)
            Xtgnbrec.MoveNext
        Loop
    End If
End Sub

Public Sub Cshgns()                                                    '初始化系统功能树
  
    Set Xtgnbrec = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM xt_xtgnb where gnbm like '23%' and MenuList=1 order by gnbm")
    tvTreeView.Nodes.Add , 4, "T", "百利/ERP5.0", "xttb"
    With Xtgnbrec
        Do While Not .EOF
            If .Fields("mjbz") Then
                Set nodX = tvTreeView.Nodes.Add("T" + Trim(.Fields("sjgnbm")), 4, "T" + Trim(.Fields("gnbm")), Trim(.Fields("gnmc")), "gnqx")
            Else
                If Trim(.Fields("sjgnbm")) = "" Then
                    Set nodX = tvTreeView.Nodes.Add("T" + Trim(.Fields("sjgnbm")), 4, "T" + Trim(.Fields("gnbm")), Trim(.Fields("gnmc")), "kpgl")
                Else
                    Set nodX = tvTreeView.Nodes.Add("T" + Trim(.Fields("sjgnbm")), 4, "T" + Trim(.Fields("gnbm")), Trim(.Fields("gnmc")), "stb")
                End If
            End If
            nodX.Tag = Xtgnbrec!mjbz
            If Len(Trim(.Fields("sjgnbm"))) <= 2 Then
                nodX.EnsureVisible
            End If
            .MoveNext
        Loop
    End With

End Sub

'系统功能树操作
Private Sub tvTreeView_BeforeLabelEdit(Cancel As Integer)                     '屏蔽编辑
  Cancel = 1
End Sub

Private Sub tvTreeView_Collapse(ByVal Node As MSComctlLib.Node)               '功能树收缩
    
    If Node.Index <> 1 And Node.Key <> "T23" Then
        Node.Image = "stb"
    End If
 
End Sub

Private Sub tvTreeView_Expand(ByVal Node As MSComctlLib.Node)                 '功能树展开
    
    If Node.Index <> 1 And Node.Key <> "T23" Then
        Node.Image = "szk"
    End If

End Sub

Private Sub tvTreeView_KeyPress(KeyAscii As Integer)                          '用户按回车键执行相应功能
    
    If KeyAscii = vbKeyReturn Then
        Call tvTreeView_DblClick
    End If

End Sub

Private Sub tvTreeView_DblClick()                                             '选择功能
    
    If tvTreeView.SelectedItem.Children = 0 Then
        Set Xtgnbrec = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM xt_xtgnb where gnbm='" + Mid(Trim(tvTreeView.SelectedItem.Key), 2, Len(Trim(tvTreeView.SelectedItem.Key)) - 1) + "'")
        If Not Xtgnbrec.EOF Then
            gnsyte = Trim(Xtgnbrec.Fields("gnsy"))
            Call Zxxymk(gnsyte)
        End If
    End If

End Sub

Public Sub Zxxymk(gnsy As String)                                            '根据用户选择执行相应程序
     Dim RecTemp As New ADODB.Recordset     '临时使用动态集
    Dim Sqlstr As String                   '临时查询字符串
  
    If Len(Trim(gnsy)) = 0 Then
        Exit Sub
    End If
    
'    '判断用户是否有此功能执行权限,如有则写上机日志(进入)
'    If Not Security_Log(gnsy, Xtczybm, 1, True) Then
'        Exit Sub
'    End If
    
    On Error GoTo Cwcl:
    Select Case gnsy
        '文件
        Case "Khgl_Register"                       '用户重新注册
            XT_login.HelpContextID = 230001
            XT_login.Show 1
            
        Case "Khgl_quit"
            Unload XT_Main
           
        
        '基础设置
        Case "Khgl_Check"                      '考核规则
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Check_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_Check.Show 1
            Security_Log "Khgl_Check_edit", Xtczybm, 2, False  '用户退出时写上机日志
            
        Case "Khgl_Point"                      '分值规则
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Point_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_Point.Show 1
            Security_Log "Khgl_Point_edit", Xtczybm, 2, False  '用户退出时写上机日志

        Case "Khgl_GauList"                      '量化规则明细
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_GauList_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_GauList.Show 1
            Security_Log "Khgl_GauList_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_ValList"                      '测评规则明细
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_ValList_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_ValList.Show 1
            Security_Log "Khgl_ValList_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_Factor"                      '考核要素设置
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Factor_edit", Xtczybm, 1) Then
                Exit Sub
            End If
        
            Khgl_Factor.Show 1
            Security_Log "Khgl_Factor_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_Title"                      '考核类别设置
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Title_edit", Xtczybm, 1) Then
                Exit Sub
            End If
        
            Khgl_Title.Show 1
            Security_Log "Khgl_Title_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_Group"                      '考核组设置
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Group_edit", Xtczybm, 1) Then
                Exit Sub
            End If
        
            Khgl_Group.Show 1
            Security_Log "Khgl_Group_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_Result"                      '结果类型设置
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Result_edit", Xtczybm, 1) Then
                Exit Sub
            End If
        
            Khgl_Result.Show 1
            Security_Log "Khgl_Result_edit", Xtczybm, 2, False  '用户退出时写上机日志
        '日常管理
        Case "Khgl_CheckQuery"                    '考核表查询
            Khgl_CheckQuery.Show 1
            
        Case "Khgl_CheckData"                    '单人考核数据
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_CheckData_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_CheckData.Show 1
            Security_Log "Khgl_CheckData_edit", Xtczybm, 2, False  '用户退出时写上机日志
        Case "Khgl_GroupData"                    '考核组考核数据
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Result_edit", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_GroupData.Show 1
            Security_Log "Khgl_GroupData_edit", Xtczybm, 2, False  '用户退出时写上机日志
        
        Case "Khgl_Compute"                     '考核数据计算
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("Khgl_Compute", Xtczybm, 1) Then
                Exit Sub
            End If
            Khgl_Compute.Show 1
            Security_Log "Khgl_Compute", Xtczybm, 2, False  '用户退出时写上机日志
        '统计分析
        Case "Khgl_Analyze"                     '考核结果分析
            Khgl_Analyze.Show
            Khgl_AnalyzeQuery.Show 1
        
        
        Case "Khgl_FactorAnalyze"                  '他评要素分析
            Khgl_FactorAnalyze.Show
        
        '工具

        Case "Khgl_gnbmjsq"                        '计算器
            Shell App.Path & "\calc.exe", vbNormalFocus
            
        '帮助
        Case "Khgl_xtbz"                           '系统帮助
            Call F1bz
        Case "Khgl_gy"                             '关于
            XT_frmAbout.Show
    End Select
    
    '用户退出时写上机日志
   Security_Log gnsy, Xtczybm, 2, False
   
    Exit Sub
Cwcl:
    Tsxx = "此项系统功能有待完善!"
    Call Xtxxts(Tsxx, 0, 4)
    Exit Sub

 
 

End Sub

Private Sub Form_QueryUnload(Cancel As Integer, UnloadMode As Integer)        '用户关闭窗体
  
    If Unload_TF = False Then
        Cancel = 1
        Me.WindowState = 1
    End If

End Sub

Private Sub Form_Load()
    
    '设置窗体图标
    Me.Icon = XT_Main.Icon
    
    '设置窗体位置大小,并调入系统功能树
    Me.Left = 0
    Me.Top = 0
    Me.Width = XT_Main.Width - 60
    Me.Height = XT_Main.Height - 760 - 690
    Call Cshgns
    
    '启动调入数据等待提示
    Load Xt_Wait
    
End Sub

Private Sub Form_Unload(Cancel As Integer)
    
    On Error Resume Next
    
    Dim i As Integer
    For i = Forms.count - 1 To 1 Step -1
        Unload Forms(i)
    Next
    If Me.WindowState <> vbMinimized Then
        SaveSetting App.Title, "Settings", "MainLeft", Me.Left
        SaveSetting App.Title, "Settings", "MainTop", Me.Top
        SaveSetting App.Title, "Settings", "MainWidth", Me.Width
        SaveSetting App.Title, "Settings", "MainHeight", Me.Height
    End If
    SaveSetting App.Title, "Settings", "ViewMode", lvListView.View

End Sub

Private Sub Form_Resize()
    
    On Error Resume Next
    If Me.Width < 3000 Then Me.Width = 3000
    SizeControls imgSplitter.Left

End Sub

Private Sub imgSplitter_MouseDown(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    With imgSplitter
        picSplitter.Move .Left, .Top, .Width \ 2, .Height - 20
    End With
    picSplitter.Visible = True
    mbMoving = True

End Sub

Private Sub imgSplitter_MouseMove(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    Dim sglPos As Single
    If mbMoving Then
        sglPos = X + imgSplitter.Left
        If sglPos < sglSplitLimit Then
            picSplitter.Left = sglSplitLimit
        ElseIf sglPos > Me.Width - sglSplitLimit Then
            picSplitter.Left = Me.Width - sglSplitLimit
        Else
            picSplitter.Left = sglPos
        End If
    End If

End Sub

Private Sub imgSplitter_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)
    
    SizeControls picSplitter.Left
    picSplitter.Visible = False
    mbMoving = False
    lvListView.Refresh

End Sub

Private Sub TreeView1_DragDrop(Source As Control, X As Single, Y As Single)
    
    If Source = imgSplitter Then
        SizeControls X
    End If

End Sub

Sub SizeControls(X As Single)
    
    On Error Resume Next

    '设置 Width 属性
    If X < 3500 Then X = 3500
    If X > (Me.Width - 1500) Then X = Me.Width - 1500
    tvTreeView.Width = X
    imgSplitter.Left = X
    lvListView.Left = X + 40
    lvListView.Width = Me.Width - (tvTreeView.Width + 140)
    lblTitle(0).Width = tvTreeView.Width
    lblTitle(1).Left = lvListView.Left + 20
    lblTitle(1).Width = lvListView.Width - 40

    '设置 Top 属性

    tvTreeView.Top = tbToolBar.Height + picTitles.Height

    lvListView.Top = tvTreeView.Top

    '设置 height 属性
    tvTreeView.Height = Me.ScaleHeight - (picTitles.Top + picTitles.Height)
    
    lvListView.Height = tvTreeView.Height
    imgSplitter.Top = tvTreeView.Top
    imgSplitter.Height = tvTreeView.Height

End Sub

Private Sub tbToolBar_ButtonClick(ByVal Button As MSComctlLib.Button)
    
    On Error Resume Next
    
    Select Case Button.Key
        Case "返回"
            tvTreeView.SetFocus
              SendKeys "{up}", True
        Case "向前"
             tvTreeView.SetFocus
              SendKeys "{DOWN}", True
        Case "大图标"
            lvListView.View = lvwIcon
        Case "小图标"
            lvListView.View = lvwSmallIcon
        Case "列表"
            lvListView.View = lvwList
        Case "详细资料"
            lvListView.View = lvwReport
    End Select

End Sub