modmanage.bas

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

Attribute VB_Name = "modManage"
Option Explicit

'
'************************************************************
'  Copyright (C), 1998-2004, ZQ Tech. Co., Ltd.
'FileName:   modManage.bas
'Author:          Version:           Date:
'  Description:     // 模块描述
'  Version:         // 版本信息
'  Function List:   // 中心模块,公用过程写在此处
'                          1.备份与恢复功能
'                          2.错误报告
'                          3.启动设置项目
'                          4.关闭程序功能
'                          5.定义公用参数
'    1. -------
'  History:         // 历史修改记录
'      <author>  <time>   <version >   <desc>
'      Amy    96/10/12     1.0     build this moudle
'***********************************************************


'
'备份与恢复------
'Private Const cnstr As String = "Provider=SQLOLEDB.1;Password=****;Persist Security Info=True;" _
'& "User ID=*****;Initial Catalog=master;Data Source=******"
'
'Private DBCn As ADODB.Connection
'
'Private Sub cmdBackup_Click()
'Set DBCn = New ADODB.Connection
'DBCn.Open cnstr
'DBCn.Execute "backup database pubs to disk='d:\pubs_backup.dat'"
'DBCn.Close
'End Sub
'
'Private Sub cmdRestore_Click()
'Set DBCn = New ADODB.Connection
'DBCn.Open cnstr
'DBCn.Execute "restore database pubs from disk='d:\pubs_backup.dat'"
'DBCn.Close
'End Sub

'----------------
'
'Public Const EM_GETLINECOUNT = &HBA
'Public Const EM_GETLINE = &HC4
'Public Const EM_LINEINDEX = &HBB
'Public Const EM_LINELENGTH = &HC1
'Public Const EM_REPLACESEL = &HC2
'Public Const EM_SETSEL = &HB1
'
'Declare Function SendMessage Lib "user32" Alias "SendMessageA" (ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, lParam As Any) As Long
'Declare Sub RtlMoveMemory Lib "KERNEL32" (lpvDest As Any, lpvSource As Any, ByVal cbCopy As Long)
'
'
'Private Sub Command1_Click()
'    Dim S As Long, Length As Integer, pos As Long, i As Integer
'    S = SendMessage(RichTextBox1.hwnd, EM_GETLINECOUNT, 0, ByVal 0&)
'    For i = 0 To S
'    pos = SendMessage(RichTextBox1.hwnd, EM_LINEINDEX, i, ByVal 0&)
'    Length = SendMessage(RichTextBox1.hwnd, EM_LINELENGTH, pos, ByVal 0&)
'    SendMessage RichTextBox1.hwnd, EM_SETSEL, pos, ByVal CLng(pos + Length + 1)
'    If i \ 2 = i / 2 Then
'       RichTextBox1.SelColor = vbGreen
'    Else
'       RichTextBox1.SelColor = vbRed
'    End If
'    Next
'End Sub
'
'a = TimeSerial(20, 45, 39)
'b = TimeSerial(20, 45, 40)

'net start mssqlserver ,用SHELL执行


'实现ListView控件的行间隔颜色
'    Dim i As Integer
'    Dim iFontHeight As Long
'    Dim iBarHeight As Integer
'    Dim j As Integer
'    Dim itmX As ListItem
'    Dim ColHead As ColumnHeader
'
'
'
'    '添加一些实验数据
'    For j = 1 To 33
'        Set itmX = ListView1.ListItems.Add()
'        itmX.Text = "This is item number " & CStr(j)
'    Next j
'
'    Me.ScaleMode = vbTwips
'    picGreenbar.ScaleMode = vbTwips
'    picGreenbar.BorderStyle = vbBSNone
'    picGreenbar.AutoRedraw = True
'    picGreenbar.Visible = False
'    picGreenbar.Font = ListView1.Font
'    iFontHeight = picGreenbar.TextHeight("b") + Screen.TwipsPerPixelY
'    iBarHeight = (iFontHeight * 1)
'    picGreenbar.Width = ListView1.Width
'    '======
'    picGreenbar.Height = iBarHeight * 2
'    picGreenbar.ScaleMode = vbUser
'    picGreenbar.ScaleHeight = 2
'    picGreenbar.ScaleWidth = 1
'    'draw the actual bars
'    picGreenbar.Line (0, 0)-(1, 1), vbWhite, BF
'    picGreenbar.Line (0, 1)-(1, 2), RGB(227, 241, 226), BF
'    '======
'    ListView1.PictureAlignment = lvwTile
'    ListView1.Picture = picGreenbar.Image

Public Declare Function GetTempPath Lib "kernel32" Alias "GetTempPathA" (ByVal nBufferLength As Long, ByVal lpBuffer As String) As Long
Public Const MAX_PATH = 260
Declare Function GetSystemMenu Lib "user32" (ByVal hwnd As Long, ByVal bRevert As Long) As Long
Declare Function RemoveMenu Lib "user32" (ByVal hMenu As Long, ByVal nPosition As Long, ByVal wFlags As Long) As Long
Public strCN As String
Public Const MF_BYPOSITION = &H400&
Public gblnLoadError As Boolean '检查启动时是否连接上数据库，flase为未找到错误，true为找到错误
Public adoConn As New ADODB.Connection '与数据库连接相关的参数和属性
Public adoLink As New ADODB.Recordset '主ado,开启后不作改变
Public adoMainLink As New ADODB.Recordset '副ado，跟着程序要求进行重新设置

Public gblnPopedom As Boolean '当前用户权限
Public gstrLink As String '临时连接项
Public gstrNowLink As String '当前使用的连接项
Public nodName As Node '定义结点
Public nodLong(2) As Integer  '结点长度
Public intCount As Integer '临时计数变量
Public strTvwName As String '部门名称
Public blnCbo As Boolean
Public blnLogout As Boolean
Public strTemp(2) As String
Public blnBoot(7) As Boolean '0为空
Public lDocumentCount As Long
Public strString(3) As String
Public blnInfo As Boolean
Public blnAbout As Boolean
Public ricBox  As RichTextBox

Public gstrName As String '当前用户名
Public datLoad  As Date '记录加载的时间
Public LinkIP As String * 16
Public gstrCro As String  '公司名称变量
Public gstrDataUser As String '数据库用户
Public gstrPassword As String '数据库密码
Public gstrProvider As String '数据库驱动
Public gblnPS As Boolean '数据库是否有密码
Public gstrDatabaseName As String '数据库名
Public gintManageCount As Integer  '部门数
Public gintManCount As Integer '员工数量
Public gstrCroLogo As String '商标路径
Public gintPactTest As Integer '试用到期人数
Public gintPactStop As Integer '合同到期人数


Public gintManageTake As Integer '记录当前选中的部门序列号

Public gblnBR As Boolean 'T is come back ,F is backup
Public gblnErrorOut As Boolean 'T:出错 F:　没错
Public gblnAdd As Boolean '作为frmInfo窗体分辨是否进行添加操作
'---hook
Public g_oMenuHook      As cHookingThunk
Public g_oMenuHookImpl  As cMenuHook
Public g_oCurrentMenu   As ctxHookMenu

#If DebugMode Then
Public g_lObjCount          As Long
#End If

'Public Declare Function SetWindowLong Lib "user32" Alias "SetWindowLongA" (ByVal hwnd As Long, ByVal nIndex As Long, ByVal dwNewLong As Long) As Long
'Public Declare Function CallWindowProc Lib "user32" Alias "CallWindowProcA" (ByVal lpPrevWndFunc As Long, ByVal hwnd As Long, ByVal Msg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
'Public PrevWndFunc As Long
'Public Const WM_GETTEXT = &HD
'Public Const EM_SETPASSWORDCHAR = &HCC
'Public Const GWL_WNDPROC = (-4)

'精华摘要
'LenB(StrConv("纯VB", vbFromUnicode)) 能读取是否占两个字节的字

'SendKeys "{Home}+{End}"

'***alter table*** --- 修改数据库表结构
'
'alter table database.owner.table_name add column_name char(2) null .....
'sp_help table_name - ---显示表已有特征
'create table table_name (name char(20), age smallint, lname varchar(30))
'insert into table_name select ......... ----- 实现删除列的方法（创建新表）
'alter table table_name drop constraint Stockname_default ---- 删除Stockname的default约束
'
Public Type ENCRYPTCLASS
  Name As String
  Object As Object
  'Homepage As String
End Type

Public EncryptObjects As ENCRYPTCLASS
Public EncryptObjectsCount As Long

Public Const BENCHMARKSIZE = 1000000

Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)

Public Function FileExist(Filename As String) As Boolean

  On Error GoTo errNext
  
  Call FileLen(Filename)
  FileExist = True
  Exit Function
  
errNext:
  Call ErrMsg(Err.Number, Err.Description)
End Function
Public Static Sub GetWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)

'  Call CopyMem(LongValue, CryptBuffer(Offset), 4)
  
  Dim bb(0 To 3) As Byte
  On Error GoTo errNext
  
  bb(3) = CryptBuffer(Offset)
  bb(2) = CryptBuffer(Offset + 1)
  bb(1) = CryptBuffer(Offset + 2)
  bb(0) = CryptBuffer(Offset + 3)
  Call CopyMem(LongValue, bb(0), 4)
    Exit Sub
  
errNext:
  'Call ErrMsg(Err.Number, Err.Description)
  Err.Clear
  gblnErrorOut = True
End Sub

Public Static Sub PutWord(LongValue As Long, CryptBuffer() As Byte, Offset As Long)

'  Call CopyMem(CryptBuffer(Offset), LongValue, 4)

  Dim bb(0 To 3) As Byte
    On Error GoTo errNext

  Call CopyMem(bb(0), LongValue, 4)
  CryptBuffer(Offset) = bb(3)
  CryptBuffer(Offset + 1) = bb(2)
  CryptBuffer(Offset + 2) = bb(1)
  CryptBuffer(Offset + 3) = bb(0)
  Exit Sub
  
errNext:
  Call ErrMsg(Err.Number, Err.Description)
End Sub
Public Static Function UnsignedAdd(ByVal Data1 As Long, Data2 As Long) As Long
  
  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
  On Error GoTo errNext
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
  
  Rest = 0
  For a = 0 To 3
    Value = CLng(x1(a)) + CLng(x2(a)) + Rest
    xx(a) = Value And 255
    Rest = Value \ 256
  Next
  
  Call CopyMem(UnsignedAdd, xx(0), 4)
  Exit Function
  
errNext:
  Call ErrMsg(Err.Number, Err.Description)
End Function

Public Function UnsignedDel(Data1 As Long, Data2 As Long) As Long

  Dim x1(0 To 3) As Byte
  Dim x2(0 To 3) As Byte
  Dim xx(0 To 3) As Byte
  Dim Rest As Long
  Dim Value As Long
  Dim a As Long
  On Error GoTo errNext
  
  Call CopyMem(x1(0), Data1, 4)
  Call CopyMem(x2(0), Data2, 4)
  Call CopyMem(xx(0), UnsignedDel, 4)
  
  For a = 0 To 3
    Value = CLng(x1(a)) - CLng(x2(a)) - Rest
    If (Value < 0) Then
      Value = Value + 256
      Rest = 1
    Else
      Rest = 0
    End If
    xx(a) = Value
  Next
  
  Call CopyMem(UnsignedDel, xx(0), 4)
  Exit Function
  
errNext:
  Call ErrMsg(Err.Number, Err.Description)
End Function

'Public Function MessageFunc(ByVal hwnd As Long, ByVal wMsg As Long, ByVal wParam As Long, ByVal lParam As Long) As Long
''wMsg:被发送的消息
'      Select Case wMsg
'          Case WM_GETTEXT
'          '发出警告
'            MsgBox "有密码窃取工具在运行，请注意！截取消息：WM_GETTEXT.", vbExclamation, "警告"
'          Case EM_SETPASSWORDCHAR
'            MsgBox "有密码窃取工具在运行，请注意！截取消息：EM_SETPASSWORDCHAR.", vbExclamation, "警告"
'          Case Else
'            MessageFunc = CallWindowProc(PrevWndFunc, hwnd, wMsg, wParam, lParam)
'      End Select
'End Function
'


Public Sub ErrMsg(strNum As String, strDes As String)
    MsgBox "错误号:    " & strNum & vbCrLf & "错误信息:  " & strDes, vbOKOnly + vbCritical, App.Title & "-运行错误"
End Sub

Public Sub Shutdown(Optional ByVal force As Boolean = False) '自定义关闭函数
    Dim lngFrmSum As Long
    On Error Resume Next
    If adoConn.State = adStateOpen Then adoConn.Close
    If adoLink.State = adStateOpen Then adoLink.Close
    If adoMainLink.State = adStateOpen Then adoMainLink.Close
    Set adoConn = Nothing
    Set adoLink = Nothing
    Set adoMainLink = Nothing
    Set ricBox = Nothing
    For lngFrmSum = Forms.Count - 1 To 0 Step -1
        Unload Forms(lngFrmSum)
        If Not force Then
            If Forms.Count > lngFrmSum Then
                Exit Sub
            End If
        End If
    Next lngFrmSum
    If force Or (Forms.Count > 0) Then End
End Sub
Sub DisSysMenu(ByVal hwnd&, ByVal MenuIndex&) '自定义菜单的关闭按钮失效
    Dim SystemMenu&, Res&
    SystemMenu& = GetSystemMenu(hwnd, 0)
    Res& = RemoveMenu(SystemMenu&, MenuIndex&, MF_BYPOSITION)
End Sub

'Public Sub subPosition(strName As String) '保存坐标
'    SaveSetting App.Title, strName, "MainLeft", Me.Left
'    SaveSetting App.Title, strName, "MainTop", Me.Top
'    SaveSetting App.Title, strName, "MainWidth", Me.Width
'    SaveSetting App.Title, strName, "MainHeight", Me.Height
'End Sub

Sub Main() '系统初始化
    If App.PrevInstance Then
        MsgBox ("程序已经运行，不能再次装载。"), vbOKOnly + vbExclamation, App.Title
        End
    End If
    blnInfo = False
    blnAbout = False
    gblnLoadError = False
    gblnBR = False
    gblnErrorOut = False
    gblnPS = False
    gintManageTake = 0
    gstrCro = "公司"
    'gstrLink = "Provider=Microsoft.Jet.OLEDB.4.0;Data Source=" & App.Path & "\人力资源.mdb;Persist Security Info=True"
    frmLogin.Show
End Sub