modulefun.bas

这是一个人事管理系统演示版,用 vb和sql 开发的

Attribute VB_Name = "ModuleFun"
'校准客户机时间，与服务器时间相同
Public Sub setSysTime()
    Dim cn As New ADODB.Connection
    Dim rs As New ADODB.Recordset
    Dim ssql As String
    
    cn.Open RSGLConnStr
    ssql = "select getdate()"
    Set rs = cn.Execute(ssql)
    Date = rs(0)
    Time = rs(0)
    cn.Close
End Sub
Public Function subname(ResultString As String, num As Integer) As String
Dim s As String
If num > 0 Then '关 键 词 的 值 不 为 空
    s = ""
    For i = 1 To 255
    If Asc(Mid$(ResultString, i, 1)) = 0 Then
       
        Exit For
    Else
     s = s & Mid$(ResultString, i, 1)
    End If
    Next
End If

subname = s
End Function
Public Function ExecuteSQL2(ByVal SQL _
   As String, MsgString As String) _
   As ADODB.Recordset

   Dim cnn As ADODB.Connection
   Dim rst As ADODB.Recordset
  
   On Error GoTo ExecuteSQL_Error
   Set rst = New ADODB.Recordset
  
   Set cnn = New ADODB.Connection
   cnn.Open RSGLConnStr
   Set com = New ADODB.Command
 
   com.ActiveConnection = cnn
   
   
   com.CommandText = SQL
   com.CommandType = adCmdStoredProc
   Set rst = com.Execute
   Set ExecuteSQL2 = rst
   
   
   
   MsgString = "查询到" & rst.RecordCount & _
         " 条记录 "

ExecuteSQL_Exit:
   Set com = Nothing
   Set rst = Nothing
   Set cnn = Nothing
   Exit Function
   
ExecuteSQL_Error:
   MsgString = "查询错误: " & _
      Err.Description
   Resume ExecuteSQL_Exit
   
   
   End Function
'错误处理
Public Sub DoWithErr(ByVal str As String)
   Dim informstr As String
   If Err.Number = -2147467259 Then
      informstr = "数据库连接超时或网络不通或服务器未启。"
   Else
      informstr = Error(Err.Number)
   End If
   MsgBox informstr, vbExclamation, "错误：" & str
   Err.Clear
End Sub



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
   SQL = LTrim(SQL)
   sTokens = Split(SQL)
  
   Set cnn = New ADODB.Connection
   cnn.Open RSGLConnStr
    Set rst = New ADODB.Recordset
        
   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
MsgBox MsgString, vbOKCancel
   Resume ExecuteSQL_Exit
   
   
   End Function


'读取系统时间
Public Function DTSystem() As String
    Dim SystemStrSql As String
    Dim SystemRST As New ADODB.Recordset
    SystemStrSql = "select getdate();"
    SystemRST.Open SystemStrSql, RSGLConnStr
    DTSystem = SystemRST.Fields(0)
    SystemRST.Close
End Function

'去掉字符串中的单引号
Function CutYH(ByVal str As String) As String
   CutYH = Replace(str, "'", "", vbTextCompare)
End Function