hrddatabase.bas

人事管理系统的一个比较不错的VB软件 有管理系统的功能

Attribute VB_Name = "Module2"
Option Explicit

Public MsgString As String
Public Cnn As New ADODB.Connection


'连接数据库服务器
Public Function ConnectionSQLServer() As Boolean
  Set Cnn = New ADODB.Connection
  On Error GoTo errorhandler
  
  Cnn.ConnectionString = "Provider=SQLOLEDB.1;" & _
      "server=" & Trim(ServerNameStr) & ";uid=" & Trim(DataCount) & ";pwd=" & Trim(PassWordStr) & ";database=" & Trim(DataBaseNameStr)
  
  Cnn.ConnectionTimeout = 20    '系统连接服务器延时20秒
  Cnn.CursorLocation = adUseClient
  Cnn.Open
  Select Case Cnn.State
    Case adStateClosed
      ConnectionSQLServer = False
    Case adStateOpen
      ConnectionSQLServer = True
    Case Cnn
      'Connecting .... Please waiting
  End Select
  Exit Function
errorhandler:
    ConnectionSQLServer = False
End Function

Public Function ExecuteSQL(ByVal SQL As String) As ADODB.Recordset
     
  Dim cmd As New ADODB.Command
  Dim rs As New ADODB.Recordset   '
  Dim sTokens() As String
 
  On Error GoTo ExecuteSQL_Error
  sTokens = Split(SQL)
  
  If Trim(SQL) = "" Then
    MsgBox "没有传入SQL语句！！", vbCritical + vbOKOnly, "语句出错："
    Exit Function
  End If
  
  If InStr("INSERT,DELETE,UPDATE", UCase$(sTokens(0))) Then '是否为新增/删除/修改
     With Cnn
        If .State = adStateOpen Then
           Set cmd.ActiveConnection = Cnn
           cmd.CommandText = SQL
           rs.Open cmd, , adOpenStatic, adLockOptimistic        '可以直接在DataGrid里修改数据
           Set ExecuteSQL = rs
        Else
           On Error GoTo ExecuteSQL_Error
        End If
     End With
     MsgString = sTokens(0) & " query successful"
  
  Else
  
     With Cnn
        If .State = adStateOpen Then
           Set cmd.ActiveConnection = Cnn
           cmd.CommandText = SQL
           'rs.Open cmd, , adOpenStatic, adLockReadOnly  '只读形式
           rs.Open cmd, , adOpenKeyset, adLockOptimistic
           Set ExecuteSQL = rs
           
        Else
           On Error GoTo ExecuteSQL_Error
           
        End If
     End With
     MsgString = "查询到" & rs.RecordCount & " 条记录 "
  End If
  

 
       
ExecuteSQL_Exit:
   Set cmd = Nothing
   Set rs = Nothing
   
   Exit Function
ExecuteSQL_Error:
   MsgString = "查询错误: " & _
      Err.Description
   Resume ExecuteSQL_Exit
  
End Function


'配置系统Ini文件  --先读取Ini配置文件,然后根据是否存在Ini文件来进行配置文件
Public Sub ReadDataIniFile()
    Dim FileNo, n, ActuaLen As Integer
    Dim PassChar(16), TempAscii As String
    Dim passlen As Integer
    FileNo = FreeFile
    Open App.Path + "\DBHrdSys.ini" For Input As FileNo
    Input #FileNo, ServerNameStr     '读入服务器名称
    Input #FileNo, DataBaseNameStr   '读入数据库名称
    Input #FileNo, DataCount         '读入数据库登陆账号
    Input #FileNo, passlen           '读入登陆服务器密码
    ActuaLen = passlen / 3 - 2
    For n = 0 To ActuaLen - 1
        Input #FileNo, TempAscii
        PassChar(n) = Chr((TempAscii - 14) / 3)
        PassWordStr = PassChar(n) & PassWordStr
    Next n
    Close #FileNo
End Sub

Public Sub SaveDataIniFile(ByVal TempPassWord As String)      'Ini文件保存
    Dim FileNo, n As Integer
    Dim Pass(16), PassStr As String
    Dim strlen As Integer
    
    PassStr = Trim(TempPassWord)
    strlen = Len(PassStr)
    n = 0
    
    FileNo = FreeFile
    Open App.Path + "\DBHrdSys.ini" For Output As FileNo
    '写入服务器名称 、数据库名称、登陆账号、数据库登陆密码
    Write #FileNo, ServerNameStr
    Write #FileNo, DataBaseNameStr
    Write #FileNo, DataCount
    Write #FileNo, (strlen + 2) * 3
    
    For n = 0 To strlen - 1
        PassStr = Left(PassStr, strlen - n)
        Pass(n) = Right(PassStr, 1)
        Write #FileNo, Asc(Pass(n)) * 3 + 14
    Next n
    
    Close #FileNo
End Sub

Public Function FindDataIniFile() As Boolean  '系统Ini文件的查找
    If Dir(App.Path + "\DBHrdSys.ini") = "" Then
       FindDataIniFile = False
    Else
       FindDataIniFile = True
    End If
End Function

Public Function CheckProgramLimit(ByVal vbProgramId As String) As Boolean
   Dim mrc As ADODB.Recordset
   Dim txtSql As String
   CheckProgramLimit = False
   txtSql = "select * from limit where Id = '" & PublicUserId & "' and  Program='" & Trim(vbProgramId) & "'"
   Set mrc = Nothing
   Set mrc = ExecuteSQL(txtSql)
   
   If Not mrc.EOF Then
      If mrc.Fields(2).Value > 0 Then
         CheckProgramLimit = True
      End If
   End If
   
   mrc.Close
   
End Function