VB开发的ERP系统

            End If
            RsItem_FrmPay.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_StandTbl")                       '标准表
            If Not Security_Log("pm_StandTb", Xtczybm, 1) Then
                Exit Sub
            End If
            Stand_FrmFirst.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_Rs_Set_RsItems")                 '人事项目设置
            If Not Security_Log("pm_Rs_Set_RsItems", Xtczybm, 1) Then
                Exit Sub
            End If
            Xtcdcs = 2
            Set_RsItemsFrm.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("Pm_Rs_Set_Position")                '人事项目排列
            If Not Security_Log("Pm_Rs_Set_Position", Xtczybm, 1) Then
                Exit Sub
            End If
            Xtcdcs = 2
            Set_PositionFrm.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        '日常处理
        Case UCase("pm_RsInfo")                         '人事信息维护
            If Not Security_Log("pm_RsInfo", Xtczybm, 1) Then
                Exit Sub
            End If
            AddExit_TF = True
            Ed_EmpArInfoFrm.FormOwner = "Self"
            Ed_EmpArInfoFrm.SysOwner = 1
            Ed_EmpArInfoFrm.Show 1
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("Pm_RsQuery")                        '人事信息查询
            If Not Security_Log("Pm_RsQuery", Xtczybm, 1) Then
                Exit Sub
            End If
            Qr_RsBasicFrm.Show
            Qr_RsBscCndFrm.Show 1
        Case UCase("pm_Copy")                           '复制数据
            If Not Security_Log("pm_Copy", Xtczybm, 1) Then
                Exit Sub
            End If
            If Xtyear = KjYear And Xtmm = Period Then
                Copy_FrmData.Show 1
            Else
                Call Xtxxts("登录时间" & Xtyear & "年" & Xtmm & "月不是当前会计期间" & _
                  KjYear & "年" & Period & "月," & Chr(10) & Chr(13) & "不能执行复制功能!", 0, 1)
            End If
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_Attend")                         '考勤录入
            If Not Security_Log("pm_Attend", Xtczybm, 1) Then
                Exit Sub
            End If
            If Xtyear = KjYear And Xtmm = Period Then
                Attend_FrmDept.Show 1
            Else
                Call Xtxxts("登录时间" & Xtyear & "年" & Xtmm & "月不是当前会计期间" & _
                  KjYear & "年" & Period & "月," & Chr(10) & Chr(13) & "不能执行考勤录入!", 0, 1)
            End If
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        Case UCase("pm_BankPayOff")                     '银行代发
            If Not Security_Log("pm_BankPayOff", Xtczybm, 1) Then
                Exit Sub
            End If
            Rep_BankPay_Frm.Show
            Query_BankPay_Frm.Show 1
        Case UCase("pm_EndMonth")
            If Not Security_Log("pm_EndMonth", Xtczybm, 1) Then
                Exit Sub
            End If
            EndM
            Security_Log gnsy, Xtczybm, 2, False  '用户退出时写上机日志
        '工具
        Case UCase("pm_calendar")                       '会计日历
            XT_kjrlFrm.Show 1
        Case UCase("pm_cal")                            '计算器
            Shell App.Path & "\calc.exe", vbNormalFocus
        
        '帮助
        Case UCase("pm_helptopic")                      '帮助主题
            Call F1bz
        Case UCase("pm_about")                          '关于
            XT_frmAbout.Show
    End Select
    Set frm = Nothing
    Set frmQuery = Nothing
   
    Exit Sub
Cwcl:
    Set frm = Nothing
    Set frmQuery = Nothing
    Tsxx = "此项系统功能有待完善!"
    Call Xtxxts(Tsxx, 0, 4)
    Exit Sub

End Sub
Private Sub EndM()
    Dim An As Integer
    Dim Rsc As New ADODB.Recordset
    '月末结转
    If Xtyear = KjYear And Xtmm = Period Then
        On Error GoTo Err1
        An = Xtxxts("进行月末结转之后，" & KjYear & "年" & _
              Period & "月的数据不能修改!" & Chr(10) & Chr(13) & "进行月末结转吗?", 1, 2)
        If An = 6 Then   'Yes
            If Period = 12 Then '如果是12月份计算本年月平均工资
                An = Xtxxts("是否计算" & KjYear & "年的月平均工资?", 1, 2)
                If An = 6 Then
                    If Rsc.State = 1 Then Rsc.Close
                    Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from PM_SortItem where EndMonth=1")
                    If Rsc.EOF Then
                        Call Xtxxts("请设置计算月平均工资的工资项目!", 0, 1)
                        Exit Sub
                    Else
                        If AveWage = -1 Then '计算本年月平均工资
                            '结转不成功
                            GoTo Err1
                        End If
                    End If
                Else
                    Cw_DataEnvi.DataConnect.Execute "update Gy_Kjrlb set PMjzbz=1 where " & _
                        " Kjyear=" & KjYear & " and Period=" & Period
                End If
            Else
                Cw_DataEnvi.DataConnect.Execute "update Gy_Kjrlb set PMjzbz=1 where " & _
                        " Kjyear=" & KjYear & " and Period=" & Period
            End If
            Call Xtxxts("结转成功!", 0, 4)
            If Rsc.State = 1 Then Rsc.Close
            Set Rsc = Cw_DataEnvi.DataConnect.Execute("select * from Gy_Kjrlb where PMjzbz=0 order by Kjyear,Period")
            If Not Rsc.EOF Then
                KjYear = Rsc!KjYear
                Period = Rsc!Period
            End If
        End If
    Else
        Call Xtxxts("登录时间" & Xtyear & "年" & Xtmm & "月不是当前会计期间" & _
          KjYear & "年" & Period & "月," & Chr(10) & Chr(13) & "不能执行月末结转!", 0, 1)
    End If
    Set Rsc = Nothing
    Exit Sub
Err1:
    Call Xtxxts("结转不成功!", 0, 1)
    Set Rsc = Nothing
End Sub
Private Function AveWage() As String
    Dim Sql As String
    Dim Rsc As New ADODB.Recordset
    Dim i As Long
    Dim Sql1 As String
    '建立视图，工资总数/月数，月数是人员实际领工资的月数
    If Rsc.State = 1 Then Rsc.Close
    Sql = "select SortID,FieldName from PM_SortItem p inner join Rs_items r " & _
          " on p.ItemID=r.ItemID where EndMonth=1"
    Set Rsc = Cw_DataEnvi.DataConnect.Execute(Sql)
    Sql = ""
    
    Do While Not Rsc.EOF
        Sql = Sql & " select " & Trim(Rsc!FieldName) & " as Wage ,Period ,EmpID " & _
              " from PM_Payroll where SortID='" & Trim(Rsc!SortId) & "'" & _
              " and Kjyear =" & KjYear & " union"
        Rsc.MoveNext
    Loop
    
    If Trim(Sql) <> "" Then
        Sql = Left(Sql, Len(Sql) - 5)
    End If
    Sql = "create view PM_V_AveWage as " & Sql
    Sql1 = "if exists (select * from dbo.sysobjects where id = object_id(N'[dbo].[PM_V_AveWage]') and OBJECTPROPERTY(id, N'IsView') = 1) " & _
         " drop view [dbo].[PM_V_AveWage] "
    On Error GoTo Err1
    With Cw_DataEnvi.DataConnect
        .BeginTrans
        .Execute Sql1
        .Execute Sql
        Sql = " update Rs_BasicInfo set PMLastYAvgSalary= AveWage from (select " & _
              " a.SumW/b.Ms as AveWage,a.EmpID from (select EmpId,sum(Wage) as SumW from PM_V_AveWage" & _
              " group by EmpId) a inner join (select  EmpID,count(distinct Period) as Ms from PM_V_AveWage " & _
              " group by EmpID) b on a.EmpID=b.EmpID ) c where Rs_BasicInfo.EmpID=c.EmpID"
        .Execute Sql
        .Execute "update Gy_Kjrlb set PMjzbz=1 where " & _
                 " Kjyear=" & KjYear & " and Period=" & Period
        .CommitTrans
    End With
    AveWage = 1
    Set Rsc = Nothing
    Exit Function
Err1:
    Cw_DataEnvi.DataConnect.RollbackTrans
    AveWage = -1
    Set Rsc = Nothing
End Function
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 0 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