获取Windows登录机器名及用户

时　间:2008-02-02 18:27:48
作　者:咱家是猫   ID：85  城市：广州
摘　要:获取Windows登录机器名及用户
正　文:

Option Compare Database
Option Explicit

Private Type UserRec
   bMach(1 To 32) As Byte
   bUser(1 To 32) As Byte
End Type

Private Function WhosOn() As String

On Error GoTo Err_WhosOn

   Dim iLDBFile As Integer, iStart As Integer
   Dim iLOF As Integer, I As Integer
   Dim sPath As String, X As String
   Dim sLogStr As String, sLogins As String
   Dim sMach As String, sUser As String
   Dim rUser As UserRec
   Dim dbCurrent As Database

   Set dbCurrent = DBEngine.Workspaces(0).Databases(0)
   sPath = dbCurrent.Name
   dbCurrent.Close
   sPath = Left(sPath, InStr(1, sPath, ".")) + "LDB"
   X = Dir(sPath)
   iStart = 1
   iLDBFile = FreeFile

   Open sPath For Binary Access Read Shared As iLDBFile
   iLOF = LOF(iLDBFile)
   Do While Not EOF(iLDBFile)
      Get iLDBFile, , rUser
      With rUser
         I = 1
         sMach = ""
         While .bMach(I) <> 0
            sMach = sMach & Chr(.bMach(I))
            I = I + 1
         Wend
         I = 1
         sUser = ""
         While .bUser(I) <> 0
            sUser = sUser & Chr(.bUser(I))
            I = I + 1
         Wend
      End With
      sLogStr = sMach & ";" & sUser
      If InStr(sLogins, sLogStr) = 0 Then
         sLogins = sLogins & sLogStr & ";"
      End If
      iStart = iStart + 64
   Loop
   Close iLDBFile
   WhosOn =  sLogins

Exit_WhosOn:
   Exit Function

Err_WhosOn:
    MsgBox Err.Description, vbExclamation, "提示"
   Resume Exit_WhosOn

End Function

实例下载:

点击这里下载