module1.bas

来自「该系统的最终用户是访问本系统的工作人员」· BAS 代码 · 共 85 行

Attribute VB_Name = "Module1"
Option Explicit
Public fMainForm As frmlegoin
Public UserName As String
Public strcomputername As String
'*****************************************************************************************************************************
'获得计算机名称的API函数
Public Declare Function GetComputerName Lib "kernel32" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

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


    Set fMainForm = New frmlegoin
    fMainForm.Show
End Sub
Public Function ConnectString() _
   As String
'returns a DB ConnectString
    Dim ComputerName As String, i As Long  '获得计算机名称的调用API函数
    i = 255
    ComputerName = String(i, 0)
    GetComputerName ComputerName, i
    ComputerName = Left(ComputerName, i)
    strcomputername = ComputerName
   ConnectString = "Provider=SQLOLEDB.1;Integrated Security=SSPI;Persist Security Info=False;Initial Catalog=stucheckbase;Data Source=" + strcomputername + ""
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

Public Function Testtxt(txt As String) As Boolean
    If Trim(txt) = "" Then
        Testtxt = False
    Else
        Testtxt = True
    End If
End Function