module1.bas

人事管理信息系统

Attribute VB_Name = "Module1"
Public fMainForm As frmMain

'记录使用的用户
Public sUserName As String

'标志是添加记录
Public Const ADD = 1
'标志是修改记录
Public Const EDIT = 2
'标志是显示记录
Public Const VIEW = 3
'表示查询
Public Const PRINTMODE = 2
'表示可写
Public Const WRITEMODE = 1
'表示可读
Public Const READMODE = 0
'标志RW权限错误
Public Const ERRORMODE = 3

'设置向SQL SERVER传递的日期格式
Public Const SQLDATEMODE = "set dateformat ymd"


Public gintMode As Integer
Public flagEdit As Boolean



Sub Main()
    Dim fLogin As New frmLogin
    fLogin.Show vbModal
    If Not fLogin.OK Then
        'Login Failed so exit app
        End
    End If
    Unload fLogin


    Set fMainForm = New frmMain
    fMainForm.Show
End Sub

Public Function ConnectString() _
   As String
'returns a DB ConnectString
   ConnectString = "FileDSN=NEWDATA.DSN;database=personnel;UID=sa;PWD=sa"
End Function
Public Function ExecuteSQL(ByVal SQL _
   As String, MsgString As String) _
   As adodb.Recordset
'executes SQL and returns Recordset
   Dim cnn As adodb.Connection
   Dim rst As adodb.Recordset
   Dim sTokens() As String
   
   On Error GoTo ExecuteSQL_Error
   
   sTokens = Split(SQL)
   Set cnn = New adodb.Connection
   cnn.Open ConnectString
   If InStr("INSERT,DELETE,UPDATE", _
      UCase$(sTokens(0))) Then
      cnn.Execute SQL
      MsgString = sTokens(0) & _
         " query successful"
   Else
      Set rst = New adodb.Recordset
      rst.Open Trim$(SQL), cnn, _
         adOpenKeyset, _
         adLockOptimistic
      'rst.MoveLast     'get RecordCount
      Set ExecuteSQL = rst
      MsgString = "查询到" & rst.RecordCount & _
         " 条记录 "
   End If
ExecuteSQL_Exit:
   Set rst = Nothing
   Set cnn = Nothing
   Exit Function
   
ExecuteSQL_Error:
   MsgString = "查询错误: " & _
      Err.Description
   Resume ExecuteSQL_Exit
End Function
'将enter换成tab
Public Sub EnterToTab(Keyasc As Integer)
    If Keyasc = 13 Then
        SendKeys "{TAB}"
    End If
End Sub
'当子窗体退出时设置MDI环境
Public Sub SetMdiEnv()
    With fMainForm
        .tbToolBar.Buttons.Item("Find").Enabled = False
        .tbToolBar.Buttons.Item("Add").Enabled = False
        .tbToolBar.Buttons.Item("Edit").Enabled = False
        .tbToolBar.Buttons.Item("Delete").Enabled = False
        .tbToolBar.Buttons.Item("Refresh").Enabled = False
        '.tbToolBar.Buttons.Item("Get").Enabled = False
        '.tbToolBar.Buttons.Item("Offer").Enabled = False
        
        .tbToolBar.Buttons.Item("Print").Enabled = False
        .tbToolBar.Buttons.Item("Preview").Enabled = False
        .mnuWork.Visible = False
        
        .mnuPreview.Enabled = False
        .mnuPrint.Enabled = False
        
    End With
End Sub
Public Sub SetWorkRW(intRW As Integer)
    If intRW = READMODE Then
        With fMainForm
            .mnuWorkAdd.Visible = False
            .mnuWorkDelete.Visible = False
            .mnuWorkEdit.Visible = False
            .tbToolBar.Buttons.Item("Add").Enabled = False
            .tbToolBar.Buttons.Item("Delete").Enabled = False
            .tbToolBar.Buttons.Item("Edit").Enabled = False
            .mnuWork.Visible = True
            '.mnuSysClose.Enabled = True
            .tbToolBar.Buttons.Item("Find").Enabled = True
           
            .tbToolBar.Buttons.Item("Refresh").Enabled = True
            
            '.tbToolBar.Buttons.Item("Print").Enabled = True
            '.tbToolBar.Buttons.Item("Preview").Enabled = True
            '.mnuPreview.Enabled = True
            '.mnuPrint.Enabled = True
            
        
        End With
    ElseIf intRW = WRITEMODE Then
        With fMainForm
            .mnuWorkAdd.Visible = True
            .mnuWorkDelete.Visible = True
            .mnuWorkEdit.Visible = True
            .tbToolBar.Buttons.Item("Add").Enabled = True
            .tbToolBar.Buttons.Item("Delete").Enabled = True
            .tbToolBar.Buttons.Item("Edit").Enabled = True
            .mnuWork.Visible = True
            '.mnuSysClose.Enabled = True
            .tbToolBar.Buttons.Item("Find").Enabled = True
           
            .tbToolBar.Buttons.Item("Refresh").Enabled = True
            
            .tbToolBar.Buttons.Item("Print").Enabled = True
            .tbToolBar.Buttons.Item("Preview").Enabled = True
            .mnuPreview.Enabled = True
            .mnuPrint.Enabled = True
            
        End With
        
  
    End If
End Sub

'------------------------------------------------------------
'这个子过程用它的 Err 码显示错误信息

'------------------------------------------------------------
Sub ShowError()
  Dim sTmp As String

  Screen.MousePointer = vbDefault
  
  sTmp = "发生了下面的错误：" & vbCrLf & vbCrLf
  
  Select Case Err.Number
    Case 7, 31001
        sTmp = sTmp & "内存溢出，需要更多的内存空间！"
    Case 28
        sTmp = sTmp & "堆栈空间溢出！"
    Case 61, 3026
        sTmp = sTmp & "磁盘已满，系统不能创建临时文件！"
    Case 76
        sTmp = sTmp & "系统需要的临时文件路径被破坏，" & vbCrLf & "请重新安装本系统！"
    Case 298
        sTmp = sTmp & "不能加载系统 DLL！"
    Case 2446
        sTmp = sTmp & "应用程序没有足够的内存来完成计算！"
    Case 3006
        sTmp = sTmp & "数据库被其它用户以独占方式使用，" & vbCrLf & "请等待该用户退出！"
    Case 3027
        sTmp = sTmp & "不能更新数据，" & vbCrLf & "数据库服务器错误！"
    Case 3036
        sTmp = sTmp & "数据库服务器的存储空间已达到最大容量，" & vbCrLf & "请系统管理员调整数据库空间！"
    Case 3151, 3059
  
        '添加错误字符串
        sTmp = sTmp & "不能连接至指定的 ODBC 数据库，" & vbCrLf & "请确认网络是否连接正常！"
    Case 3218
        sTmp = sTmp & "所修改的数据正被其它用户使用，" & vbCrLf & "不能被修改！"
    Case 3239
        sTmp = sTmp & "太多用户同时使用数据系统，" & vbCrLf & "请等待一个或一个以上的用户退出使用此系统，然后重试一次。"
    Case Else
        sTmp = "系统错误：" & vbCrLf & vbCrLf
        '添加错误字符串
        sTmp = sTmp & Err.Description & vbCrLf
        sTmp = sTmp & Err.Number
  End Select
  
  Beep
  '显示错误
  MsgBox sTmp, vbOKOnly + vbCritical, "错误"

End Sub