mdimain.frm

人事管理系统vb版,用于一般中小企业

      Caption         =   "&T.工具"
      Begin VB.Menu mnuData 
         Caption         =   "备份数据库(&B)..."
         Index           =   0
      End
      Begin VB.Menu mnuData 
         Caption         =   "恢复数据库(&R)..."
         Index           =   1
      End
      Begin VB.Menu mnuDataYS 
         Caption         =   "压缩数据库(&C)..."
      End
   End
   Begin VB.Menu mnuWindow 
      Caption         =   "&W.视图"
      WindowList      =   -1  'True
      Begin VB.Menu mnuHandle 
         Caption         =   "监控台(&B)"
         Checked         =   -1  'True
      End
      Begin VB.Menu line6 
         Caption         =   "-"
      End
      Begin VB.Menu mnubackPic 
         Caption         =   "背景图片"
         Begin VB.Menu mnuNone 
            Caption         =   "无(&N)"
         End
         Begin VB.Menu mnuPic 
            Caption         =   "蓝天白云"
            Index           =   0
         End
         Begin VB.Menu mnuPic 
            Caption         =   "苹果时代"
            Index           =   1
         End
         Begin VB.Menu mnuPic 
            Caption         =   "星光灿烂"
            Index           =   2
         End
         Begin VB.Menu mnuPic 
            Caption         =   "我的办公桌"
            Index           =   3
         End
         Begin VB.Menu line7 
            Caption         =   "-"
         End
         Begin VB.Menu mnuBrowse 
            Caption         =   "浏览图片(&B)..."
         End
      End
      Begin VB.Menu mnuLine8 
         Caption         =   "-"
      End
      Begin VB.Menu mnuTool 
         Caption         =   "工具栏(&T)"
         Checked         =   -1  'True
         Index           =   0
      End
      Begin VB.Menu mnuTool 
         Caption         =   "状态栏(&S)"
         Checked         =   -1  'True
         Index           =   1
      End
   End
   Begin VB.Menu mnuHelps 
      Caption         =   "&H.帮助"
      Begin VB.Menu mnuHelp 
         Caption         =   "帮助主题"
         Shortcut        =   ^H
      End
      Begin VB.Menu mnuline2 
         Caption         =   "-"
      End
      Begin VB.Menu mnuUpdate 
         Caption         =   "更新下载"
         Shortcut        =   ^U
      End
      Begin VB.Menu mnuAbout 
         Caption         =   "关于..."
         Shortcut        =   ^A
      End
   End
End
Attribute VB_Name = "MDIMain"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
Dim intCount As Integer
Dim strText As String
Dim intButton As Integer
Dim intCmdIndex As Integer
Dim intBar As Integer
Dim intMove As Integer
Dim intMenuMove As Integer
Dim picPath As String
Dim objFile As Object
Private Sub subMenu()
    intMenuMove = intMove
    Select Case intCmdIndex
    Case 0:
        For intCount = 0 To 3
            tbrMenu(intCount).Visible = True
            lblMenu(intCount).Visible = True
            tbrMenu(intCount).Top = 600 + intMenuMove
            lblMenu(intCount).Top = 1560 + intMenuMove
            intMenuMove = intMenuMove + 1320
        Next
        For intCount = 4 To 15
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
    Case 1:
        For intCount = 0 To 3
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
        For intCount = 4 To 8
            tbrMenu(intCount).Visible = True
            lblMenu(intCount).Visible = True
            tbrMenu(intCount).Top = 975 + intMenuMove
            lblMenu(intCount).Top = 1935 + intMenuMove
            intMenuMove = intMenuMove + 1320
        Next
        For intCount = 9 To 15
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
    Case 2:
        For intCount = 0 To 8
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
        For intCount = 9 To 11
            tbrMenu(intCount).Visible = True
            lblMenu(intCount).Visible = True
            tbrMenu(intCount).Top = 1350 + intMenuMove
            lblMenu(intCount).Top = 2310 + intMenuMove
            intMenuMove = intMenuMove + 1320
        Next
        For intCount = 12 To 15
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
    Case 3:
            For intCount = 0 To 11
            tbrMenu(intCount).Visible = False
            lblMenu(intCount).Visible = False
        Next
        For intCount = 12 To 15
            tbrMenu(intCount).Visible = True
            lblMenu(intCount).Visible = True
            tbrMenu(intCount).Top = 1725 + intMenuMove
            lblMenu(intCount).Top = 2685 + intMenuMove
            intMenuMove = intMenuMove + 1320
        Next
    End Select
    Call MDIForm_Resize
End Sub

Private Sub chkhandle_Click()
    mnuHandle.Checked = Not CBool(chkhandle.Value)
    frmHandle.Visible = mnuHandle.Checked
End Sub

Private Sub mnuAttribute_Click()
MsgBox "数据库路径：" & gstrDatabaseName & vbCrLf & "数据库是否加密:" & IIf(gblnPS = True, "是", "否") & vbCrLf & "数据源提供:" & gstrProvider & _
    vbCrLf & "使用单位:" & gstrCro & vbCrLf & "部门数量:" & gintManageCount & "个" & vbCrLf & "员工数量:" & _
    gintManCount & "人" & vbCrLf & "合同到期:" & gintPactStop & "人" & vbCrLf & "试用到期:" & gintPactTest & "人" & vbCrLf & _
    "管理员:" & gstrName & vbCrLf & "管理员权限:" & IIf(gblnPopedom = True, "高级用户", "普通用户") & _
    vbCrLf & "登录时间:" & datLoad & vbCrLf & "登录IP:" & LinkIP, vbInformation, "当前属性"
End Sub

Private Sub mnuData_Click(Index As Integer)
    On Error GoTo CompactErr
    Set objFile = CreateObject("scripting.filesystemobject")
    Dim strBR As String
    With MDIMain.cdgMain
        Select Case Index
        Case 0:
            strBR = "备份"
            .DialogTitle = "数据库备份为..."
            .Filename = ""
            .Filter = "Access数据库(*.mdb)|*.mdb|"
            .ShowSave
            If Len(.Filename) = 0 Then Exit Sub
            If objFile.fileExists(.Filename) = True Then
                If MsgBox("发现备份文件已存在,是否覆盖?", vbInformation + vbOKCancel, App.Title) = vbCancel Then
                    MsgBox "备份操作未完成!", vbExclamation, App.Title
                    Exit Sub
                End If
            End If
            objFile.CopyFile gstrDatabaseName, .Filename
        Case 1:
            strBR = "恢复"
             If MsgBox("恢复数据库操作将覆盖当前使用的数据库,确认要恢复吗?", vbInformation + vbYesNo, App.Title) = vbYes Then
                 .DialogTitle = "数据库恢复为..."
                 .Filename = ""
                 .Filter = "Access数据库(*.mdb)|*.mdb|"
                 .ShowOpen
                  If Len(.Filename) = 0 Then Exit Sub
                 If .Filename = gstrDatabaseName Then
                     MsgBox "选中的数据库就是当前操作的数据库," & vbTab & vbCrLf & vbCrLf & "恢复操作失败,请重新选择数据库!", vbExclamation, App.Title
                     Exit Sub
                 End If
                 If adoConn.State = adStateOpen Then adoConn.Close
                 Set adoConn = Nothing
                 objFile.CopyFile .Filename, gstrDatabaseName
                 adoConn.CursorLocation = adUseClient
                 adoConn.Open gstrNowLink
             Else
                 MsgBox "恢复操作未完成!", vbExclamation, App.Title
                 Exit Sub
            End If
        End Select
    End With
    MsgBox "数据库" & strBR & "成功!", vbInformation, "系统提示"
    Exit Sub
CompactErr:
        Call ErrMsg(Err.Number, Err.Description)
        Set objFile = Nothing
End Sub

Private Sub mnuDataYS_Click()
    On Error GoTo CompactErr
    Dim dbEngine As New JRO.JetEngine
    If MsgBox("数据库压缩后将大幅度提升访问性能,继续吗?(Y/N)", vbInformation + vbYesNo) = vbYes Then
        If gstrProvider < "Microsoft.Jet.OLEDB.4.0" Then MsgBox "只有Microsoft.Jet.OLEDB.4.0及以上版本才具有压缩功能!", vbExclamation: GoTo EngineNothing
        With adoConn
            If .State = adStateOpen Then .Close
            Set adoConn = Nothing
            Dim strBackupFile As String
            Dim strTempFile As String
            If Len(Dir(gstrDatabaseName)) Then '检查数据库文件是否存在
                Dim strFolder As String
                Dim lngResult As Long
                Dim GetTemporaryPath  As String
                strFolder = String(MAX_PATH, 0) '找出系统的临时目录地址
                lngResult = GetTempPath(MAX_PATH, strFolder)
                If lngResult <> 0 Then
                    GetTemporaryPath = Left(strFolder, InStr(strFolder, Chr(0)) - 1)
                Else
                    GetTemporaryPath = ""
                End If
                strBackupFile = GetTemporaryPath & "backup.mdb" '备份数据库
                If Len(Dir(strBackupFile)) Then Kill strBackupFile
                FileCopy gstrDatabaseName, strBackupFile
                strTempFile = GetTemporaryPath & "temp.mdb" ' 创建临时文件名
                If Len(Dir(strTempFile)) Then Kill strTempFile
                If gblnPS = True Then
                    dbEngine.CompactDatabase "Data Source=" & gstrDatabaseName & ";Jet OLEDB:Database Password=" & gstrPassword & "", "Data Source=" & strTempFile & ";Jet OLEDB:Encrypt Database=true;Jet OLEDB:Database Password=" & gstrPassword & ""  '通过DBEngine 压缩数据库文件有密码
                Else
                    dbEngine.CompactDatabase "Data Source=" & gstrDatabaseName & ";Jet OLEDB:Encrypt Database=false", "Data Source=" & strTempFile & ";Jet OLEDB:Encrypt Database=false"   '通过DBEngine 压缩数据库文件无密码
                End If
                Kill gstrDatabaseName ' 删除原来的数据库文件
                FileCopy strTempFile, gstrDatabaseName ' 拷贝刚刚压缩过临时数据库文件至原来位置
                Kill strTempFile ' 删除临时文件
            End If
            MsgBox "压缩数据库成功!", vbInformation, App.Title
                 adoConn.CursorLocation = adUseClient
                 adoConn.Open gstrNowLink
        End With
    Else
        MsgBox "压缩数据库未完成!", vbExclamation, App.Title
    End If
    GoTo EngineNothing
CompactErr:
    Call ErrMsg(Err.Number, Err.Description)
EngineNothing:
    Set dbEngine = Nothing
End Sub

Private Sub mnuDoc_Click(Index As Integer)
    Call tbrMenu_ButtonClick(Index + 9, tbrMenu(Index + 9).Buttons.Item(1))
End Sub

Private Sub mnuHandle_Click()
    mnuHandle.Checked = Not mnuHandle.Checked
    frmHandle.Visible = mnuHandle.Checked
    chkhandle.Value = Abs(CInt(mnuHandle.Checked))
End Sub

Private Sub cmdMenu_Click(Index As Integer)
    If intCmdIndex = Index Then Exit Sub
    intCmdIndex = Index
    picMenu.Picture = iltBottom.ListImages(Index + 1).Picture
    intMenuMove = 0
    intMove = 0
    flaBar.Value = 0
    Call subMenu
End Sub

Private Sub flaBar_Change()
    intMove = -flaBar.Value
    Call subMenu
End Sub

Private Sub MDIForm_Load()
    On Error Resume Next
    Me.Caption = App.Title & " Ver " & App.Major & "." & App.Minor
    intButton = 2
    picMenu.Visible = False
    blnAbout = True
    Me.Left = GetSetting(App.Title, "Settings", "MainLeft", 1000)
    Me.Top = GetSetting(App.Title, "Settings", "MainTop", 1000)
    Me.Width = GetSetting(App.Title, "Settings", "MainWidth", 8500)
    Me.Height = GetSetting(App.Title, "Settings", "MainHeight", 6500)
    mnuTool(0).Checked = CBool(GetSetting(App.Title, "Settings", "MenuTool0", True))
    mnuTool(1).Checked = CBool(GetSetting(App.Title, "Settings", "MenuTool1", True))
    tbrTool.Visible = mnuTool(0).Checked
    staInfo.Visible = mnuTool(1).Checked
    picPath = GetSetting(App.Title, "Settings", "backPicture", App.Path & "\蓝天白云.jpg")
    Me.Picture = LoadPicture(picPath)
    LinkIP = winIP.LocalIP
    With cmuMain
        .UseSystemFont = False
        .MenuDrawStyle = DS_XP
        .DrawStyle = MS_自定义 'MS_默认 ' MS_Custom
        .DisplayShadow = True
        '.SetCustomAttributes 16761765, 16769990, 13040639, 16769990, vbBlue, &H800000, _
                vbBlue, 8108783, vbBlue, vbWhite, 16761765, vbBlue, &H800080, True, False
        .SetCustomAttributes 16761765, 16769990, 13040639, 16769990, vbBlue, &H800000, _
                vbBlue, 8108783, vbBlue, vbWhite, 16761765, vbBlue, &H800080, True, True
        .SetBitmapByCaption "mnuPrintSet", iltPic18.ListImages(3).Picture, &H80000005
        .SetBitmapByCaption "mnuExit", iltPic18.ListImages(4).Picture, &H80000005
        .SetBitmapByCaption "mnuMan:0", iltPic18.ListImages(2).Picture, &H80000005
        .SetBitmapByCaption "mnuMan:1", iltPic18.ListImages(5).Picture, &H80000005
        .SetBitmapByCaption "mnuMan:2", iltPic18.ListImages(6).Picture, &H80000005
        .SetBitmapByCaption "mnuMan:3", iltPic18.ListImages(7).Picture, &H80000005
        .SetBitmapByCaption "mnuOffice:0", iltPic18.ListImages(8).Picture, &H80000005
        .SetBitmapByCaption "mnuOffice:1", iltPic18.ListImages(9).Picture, &H80000005
        .SetBitmapByCaption "mnuOffice:2", iltPic18.ListImages(10).Picture, &H80000005
        .SetBitmapByCaption "mnuOffice:3", iltPic18.ListImages(11).Picture, &H80000005
        .SetBitmapByCaption "mnuOffice:4", iltPic18.ListImages(12).Picture, &H80000005
        .SetBitmapByCaption "mnuDoc:0", iltPic18.ListImages(13).Picture, &H80000005
        .SetBitmapByCaption "mnuDoc:1", iltPic18.ListImages(14).Picture, &H80000005
        .SetBitmapByCaption "mnuDoc:2",