'mWorkstationInfo
' Gets workstation information such as username, computername and domain
' Public functions listing
' 1 fWorkstationInfo_ComputerName()
' 2 fWorkstationInfo_UserName()
' 3 fWorkstationInfo_LogonDomain()
' 4 fWorkstationInfo_LanGroup()
Type WKSTA_INFO_101
wki101_platform_id As Long
wki101_computername As Long
wki101_langroup As Long
wki101_ver_major As Long
wki101_ver_minor As Long
wki101_lanroot As Long
End Type
Type WKSTA_USER_INFO_1
wkui1_username As Long
wkui1_logon_domain As Long
wkui1_logon_server As Long
wkui1_oth_domains As Long
End Type
Declare PtrSafe Function WNetGetUser& _
Lib "Mpr" Alias "WNetGetUserA" _
(lpName As Any, ByVal lpUserName$, lpnLength&)
Declare PtrSafe Function NetWkstaGetInfo& _
Lib "Netapi32" _
(strServer As Any, ByVal lLevel&, pbBuffer As Any)
Declare PtrSafe Function NetWkstaUserGetInfo& _
Lib "Netapi32" _
(reserved As Any, ByVal lLevel&, pbBuffer As Any)
Declare PtrSafe Sub lstrcpyW _
Lib "kernel32" _
(dest As Any, ByVal src As Any)
Declare PtrSafe Sub lstrcpy _
Lib "kernel32" _
(dest As Any, ByVal src As Any)
Declare PtrSafe Sub RtlMoveMemory _
Lib "kernel32" _
(dest As Any, src As Any, ByVal size&)
Declare PtrSafe Function NetApiBufferFree& _
Lib "Netapi32" _
(ByVal buffer&)
Public Function fWorkstationInfo(Optional strWhatInfoWanted As String) As String
'General declarations
Dim ret As Long, buffer(512) As Byte, i As Integer
Dim wk101 As WKSTA_INFO_101, pwk101 As Long
Dim wk1 As WKSTA_USER_INFO_1, pwk1 As Long
Dim cbusername As Long
Dim computerName As String, lanGroup As String, logonDomain As String, userName As String
'Initializations
computerName = "": lanGroup = "": userName = "": logonDomain = ""
'Call WNetGetUser to get the name of the user.
userName = Space(256)
cbusername = Len(userName)
ret = WNetGetUser(ByVal 0&, userName, cbusername)
If ret = 0 Then
userName = Left(userName, InStr(userName, Chr(0)) - 1) 'Success - strip off the null.
Else
userName = ""
End If
'================================================================
' The following section works only under Windows NT
'NT only - call NetWkstaGetInfo to get computer name and lan group
ret = NetWkstaGetInfo(ByVal 0&, 101, pwk101)
RtlMoveMemory wk101, ByVal pwk101, Len(wk101)
lstrcpyW buffer(0), wk101.wki101_computername
' Get every other byte from Unicode string.
i = 0
Do While buffer(i) <> 0
computerName = computerName & Chr(buffer(i))
i = i + 2
Loop
lstrcpyW buffer(0), wk101.wki101_langroup
i = 0
Do While buffer(i) <> 0
lanGroup = lanGroup & Chr(buffer(i))
i = i + 2
Loop
ret = NetApiBufferFree(pwk101)
' NT only - call NetWkstaUserGetInfo.
ret = NetWkstaUserGetInfo(ByVal 0&, 1, pwk1)
RtlMoveMemory wk1, ByVal pwk1, Len(wk1)
lstrcpyW buffer(0), wk1.wkui1_logon_domain
i = 0
Do While buffer(i) <> 0
logonDomain = logonDomain & Chr(buffer(i))
i = i + 2
Loop
ret = NetApiBufferFree(pwk1)
'End NT-specific section
'================================================================
'Return the desired value
Select Case strWhatInfoWanted
Case "lanGroup": fWorkstationInfo = lanGroup
Case "computerName": fWorkstationInfo = computerName
Case "userName": fWorkstationInfo = userName
Case "logonDomain": fWorkstationInfo = logonDomain
Case Else: fWorkstationInfo = userName & ";" & computerName & ";" & logonDomain & ";" & lanGroup
End Select
'Debug.Print computerName, lanGroup, userName, logonDomain
End Function
'Public functions
Public Function fWorkstationInfo_ComputerName()
fWorkstationInfo_ComputerName = fWorkstationInfo("computerName")
End Function
Public Function fWorkstationInfo_UserName()
' fWorkstationInfo_UserName = fWorkstationInfo("userName")
Dim s As String
s = fWorkstationInfo("userName")
' Salvador using the system within his network
If s = "Salvador.Delgadom" Then
s = "501963464"
' Carlos' 32-bit virtual machine
ElseIf s = "me" Then
s = "213061316"
End If
' Return
fWorkstationInfo_UserName = s
End Function
Public Function fWorkstationInfo_LogonDomain()
fWorkstationInfo_LogonDomain = fWorkstationInfo("logonDomain")
End Function
Public Function fWorkstationInfo_LanGroup()
fWorkstationInfo_LanGroup = fWorkstationInfo("lanGroup")
End Function
' LDB
Public Function getUserRoster() As String
' Declare, init
Dim cn As New ADODB.Connection
Dim cn2 As New ADODB.Connection
Dim RS As New ADODB.Recordset
Dim i, j As Long
Dim result As String
result = ""
Dim str_Path As String
str_Path = CurrentProject.Path & "\" & CurrentProject.Name
cn.Provider = "Microsoft.ACE.OLEDB.12.0"
cn.Open "Data Source=" & str_Path
cn2.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & str_Path
' The user roster is exposed as a provider-specific schema rowset
' in the Jet 4 OLE DB provider. You have to use a GUID to
' reference the schema, as provider-specific schemas are not
' listed in ADO's type library for schema rowsets
Set RS = cn.OpenSchema(adSchemaProviderSpecific, , "{947bb102-5d43-11d1-bdbf-00c04fb92675}")
'Output the list of all users in the current database.
'Debug.Print _
rs.Fields(0).Name, "", _
rs.Fields(1).Name, "", _
rs.Fields(2).Name, _
rs.Fields(3).Name
While Not RS.EOF
'Debug.Print _
rs.Fields(0) _
, rs.Fields(1) _
, rs.Fields(2) _
, rs.Fields(3)
If InStr(1, result, Trim(RS.Fields(1)) & ";", vbTextCompare) = 0 Then
result = result & Trim(RS.Fields(1)) & ";"
End If
RS.MoveNext
Wend
' Discard objects
Set RS = Nothing
Set cn2 = Nothing
Set cn = Nothing
'Exit
getUserRoster = result
End Function
No comments:
Post a Comment