VB开发的ERP系统

Private Declare Function OSWinHelp% Lib "user32" Alias "WinHelpA" (ByVal hwnd&, ByVal HelpFile$, ByVal wCommand%, dwData As Any)
  
Dim mbMoving As Boolean
Const sglSplitLimit = 1000

Dim nodx As Node
Dim mitem As ListItem

Dim Ztxxrec As New ADODB.Recordset           '帐套信息动态集
Dim Xtgnbrec As New ADODB.Recordset          '系统功能表
Dim Xtqxxzrec As New ADODB.Recordset         '系统权限限制动态集
Dim Tsxx As String                           '系统提示信息
Dim gnsyte As String                         '系统功能项索引
Dim Xtrlrec As New ADODB.Recordset           '系统日历动态集
Dim Ctsfscdr As Boolean                      '窗体是否首次读入
Dim sjgnbmStr As String                      '上级编码

Private Sub lvListView_DblClick()            '点击ListView执行相应功能
    If lvListView.ListItems.Count > 0 Then
        Set Xtgnbrec = Cw_DataEnvi.DataConnect.Execute("SELECT * FROM xt_xtgnb where gnbm='" + Mid(Trim(lvListView.SelectedItem.Key), 2, Len(Trim(lvListView.SelectedItem.Key)) - 1) + "'")
        If Not Xtgnbrec.EOF Then
            If Xtgnbrec.Fields("mjbz") = True Then
                gnsyte = Trim(Xtgnbrec.Fields("gnsy"))
                Call Zxxymk(gnsyte)
            Else
                '---------------
                Dim sSql As String
                sjgnbmStr = ""
                lvListView.ColumnHeaders.Clear
                lvListView.ListItems.Clear
                sSql = "SELECT * FROM xt_xtgnb where sjgnbm='" + Xtgnbrec.Fields("gnbm") + "' and MenuList=1 order by gnbm"
                Set Xtgnbrec = Cw_DataEnvi.DataConnect.Execute(sSql)
                lvListView.ColumnHeaders.Add 1, "rcsw", tvTreeView.SelectedItem.Text, 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 If
    End If
End Sub
Private Sub lvListView_KeyPress(KeyAscii As Integer)
    If KeyAscii = vbKeyReturn Then
        Call lvListView_DblClick
    End If
End Sub
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 '22%' 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 <> "T22" Then
        Node.Image = "stb"
    End If
 
End Sub

Private Sub tvTreeView_Expand(ByVal Node As MSComctlLib.Node)                 '功能树展开
    
    If Node.Index <> 1 And Node.Key <> "T22" 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                   '临时查询字符串
    Dim An As Integer
    
    Dim frm As Form
    Dim frmQuery As Form
    If Len(Trim(gnsy)) = 0 Then
        Exit Sub
    End If
    
   
    On Error GoTo Cwcl:
    Select Case UCase(gnsy)
        Case UCase("PM_ReportItem") '报表项目选择
            If Not Security_Log("PM_ReportItem", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_SelectItem_Frm
            frm.Show 1
            Set frm = Nothing
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("Pm_Query") '通用查询
            
            Set frm = New Query_Frm
            frm.Show 1
            Set frm = Nothing
        Case UCase("PM_Formula") '公式定义
            If Not Security_Log("pm_Formula", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Formula_Create_Frm
            frm.Show 1
            Set frm = Nothing
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("PM_ComputeSalary") '计算工资
            If Not Security_Log("pm_ComputeSalary", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Salary_Frm_Compute
            frm.Show 1
            Set frm = Nothing
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("PM_Tax") '个人所得税
            If Not Security_Log("pm_Tax", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_Tax_Frm
            Set frmQuery = New Query_Tax_Frm
            frm.Show
            frmQuery.sTableName = "PM_TaxData"
            Set frmQuery.frmParent = frm
            frmQuery.Show 1
            
        Case UCase("Pm_SalarySignal") '工资签名表
            If Not Security_Log("pm_SalarySignal", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_DIYSalary_Frm
            frm.sRCode = "001"
            frm.sPTableName = "PM_PayRoll"
            frm.HelpContextID = 2214002
            frm.Show
            Set frmQuery = New Query_RepSalary_Frm
            frmQuery.sRCode = "001"
            frmQuery.sPTableName = "PM_PayRoll"
            Set frmQuery.frmParent = frm
            frmQuery.Show 1
            
        Case UCase("Pm_RepSalaryPay") '工资发放表
            If Not Security_Log("pm_RepSalaryPay", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_DIYSalary_Frm
            frm.sRCode = "002"
            frm.sPTableName = "PM_PayRoll"
            frm.HelpContextID = 2214003
            frm.Show
            Set frmQuery = New Query_RepSalary_Frm
            frmQuery.sRCode = "002"
            frmQuery.sPTableName = "PM_PayRoll"
            Set frmQuery.frmParent = frm
            frmQuery.Show 1
            
        Case UCase("Pm_RepSalarySum") '工资汇总表
            If Not Security_Log("pm_RepSalarySum", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_DIYSalary_Frm
            frm.sRCode = "003"
            frm.sPTableName = "PM_PayRoll"
            frm.HelpContextID = 2214004
            frm.Show
            Set frmQuery = New Query_RepSalary_Frm
            frmQuery.sRCode = "003"
            frmQuery.sPTableName = "PM_PayRoll"
            Set frmQuery.frmParent = frm
            frmQuery.Show 1
            
        Case UCase("Pm_RepAttend") '考勤分析表
            If Not Security_Log("pm_RepAttend", Xtczybm, 1) Then
                Exit Sub
            End If
            Set frm = New Rep_DIYAttend_Frm
            frm.sRCode = "004"
            frm.sPTableName = "PM_AttendRecord"
            frm.Show
            Set frmQuery = New Query_RepAttend_Frm
            frmQuery.sRCode = "004"
            frmQuery.sPTableName = "PM_AttendRecord"
            Set frmQuery.frmParent = frm
            frmQuery.Show 1
                        
        Case UCase("pm_register")                       '用户重新注册
            XT_login.Show 1
        Case UCase("pm_Ini")                            '数据初始化
            If Xtxxts("数据初始化将会删除所有的数据，" & Chr(13) & Chr(10) & "进行数据初始化吗？", 1, 2) = 6 Then
               Call initializtion
            End If
        Case UCase("pm_exit")                           '退出系统
            Unload XT_Main
        '基础设置
        Case UCase("pm_bank")                           '银行信息
            '判断用户是否有此功能执行权限,如有则写上机日志(进入)
            If Not Security_Log("pm_bank", Xtczybm, 1) Then
                Exit Sub
            End If
            Bank_frmInfo.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志

        Case UCase("pm_TaxRate")                        '税率设置
            If Not Security_Log("pm_TaxRate", Xtczybm, 1) Then
                Exit Sub
            End If
            Tax_FrmRate.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
      
        Case UCase("pm_FixItem")                        '固定项设置
            Item_FrmSetFix.Show 1
        Case UCase("pm_Item")                           '项目设置
            If Not Security_Log("pm_Item", Xtczybm, 1) Then
                Exit Sub
            End If
            Item_FrmSet.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_sort")                           '类别设置
            If Not Security_Log("pm_sort", Xtczybm, 1) Then
                Exit Sub
            End If
            Class_FrmSet.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_OpePope")                     '操作员权限设置
            If Not Security_Log("pm_OpePope", Xtczybm, 1) Then
                Exit Sub
            End If
            Operator_Frm.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_SortItem")                       '类别项目选择
            If Not Security_Log("pm_SortItem", Xtczybm, 1) Then
                Exit Sub
            End If
            Class_FrmItem.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_SortEmp")                        '类别人员选择
            If Not Security_Log("pm_SortEmp", Xtczybm, 1) Then
                Exit Sub
            End If
            Class_frmEmp.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_BankItem")                       '代发栏目设置
            If Not Security_Log("pm_BankItem", Xtczybm, 1) Then
                Exit Sub
            End If
            Bank_FrmColSet.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_RsItem")                         '人事项目选择
            If Not Security_Log("pm_RsItem", Xtczybm, 1) Then
                Exit Sub