Option Compare Database
Option Explicit
Declare Function wu_WNetGetUser Lib "advapi32.dll" Alias "GetUserNameA" (ByVal sUser As String, nBuffer As Long) As Long
Declare Function GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Declare Function CreateDirectory Lib "kernel32.dll" Alias "CreateDirectoryA" (ByVal lpPathName As String, lpSecurityAttributes As SECURITY_ATTRIBUTES) As Long
Declare Function gethostbyaddr Lib "wsock32.dll" (addr As Long, ByVal Length As Long, ByVal protocol As Long) As Long
Declare Function htonl Lib "wsock32.dll" (ByVal hostlong As Long) As Long
Declare Function apiNetGetDCName Lib "netapi32.dll" Alias "NetGetDCName" (ByVal servername As Long, ByVal DomainName As Long, bufptr As Long) As Long
' function frees the memory that the NetApiBufferAllocate
' function allocates.
Declare Function apiNetAPIBufferFree Lib "netapi32.dll" Alias "NetApiBufferFree" (ByVal buffer As Long) As Long '
'Retrieves the length of the specified wide string.
Declare Function apilstrlenW Lib "kernel32" Alias "lstrlenW" (ByVal lpString As Long) As Long
Declare Function apiNetUserGetInfo Lib "netapi32.dll" Alias "NetUserGetInfo" (servername As Any, username As Any, _
ByVal level As Long, bufptr As Long) As Long
' moves memory either forward or backward, aligned or unaligned,
' in 4-byte blocks, followed by any remaining bytes
Declare Sub sapiCopyMem Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Declare Function apiGetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Type SECURITY_ATTRIBUTES
nLength As Long
lpSecurityDescriptor As Long
bInheritHandle As Boolean
End Type
Const AF_12844 = 25
Const AF_APPLETALK = 16
Const AF_ATM = 22
Const AF_BAN = 21
Const AF_CCITT = 10
Const AF_CHAOS = 5
Const AF_CLUSTER = 24
Const AF_DATAKIT = 9
Const AF_DECnet = 12
Const AF_DLI = 13
Const AF_ECMA = 8
Const AF_FIREFOX = 19
Const AF_HYLINK = 15
Const AF_IMPLINK = 3
Const AF_INET = 2
Const AF_INET6 = 23
Const AF_IPX = 6
Const AF_ISO = 7
Const AF_LAT = 14
Const AF_NETBIOS = 17
Const AF_NS = 6
Const AF_OSI = 7
Const AF_PUP = 4
Const AF_SNA = 11
Const AF_UNIX = 1
Const AF_UNKNOWN1 = 20
Const AF_VOICEVIEW = 18
Const MAXCOMMENTSZ = 256
Const NERR_SUCCESS = 0
Const ERROR_MORE_DATA = 234&
Const MAX_CHUNK = 25
Const ERROR_SUCCESS = 0&
Public Type USER_INFO_2
usri2_name As Long
usri2_password As Long ' Null, only settable
usri2_password_age As Long
usri2_priv As Long
usri2_home_dir As Long
usri2_comment As Long
usri2_flags As Long
usri2_script_path As Long
usri2_auth_flags As Long
usri2_full_name As Long
usri2_usr_comment As Long
usri2_parms As Long
usri2_workstations As Long
usri2_last_logon As Long
usri2_last_logoff As Long
usri2_acct_expires As Long
usri2_max_storage As Long
usri2_units_per_week As Long
usri2_logon_hours As Long
usri2_bad_pw_count As Long
usri2_num_logons As Long
usri2_logon_server As Long
usri2_country_code As Long
usri2_code_page As Long
End Type
Function GetUserFullName(Optional strUserName As String) As String
'
' Returns the full name for a given UserID
' NT/2000 only
' Omitting the strUserName argument will try and
' retrieve the full name for the currently logged on user
'
On Error GoTo ErrHandler
Dim pBuf As Long
Dim dwRec As Long
Dim pTmp As USER_INFO_2
Dim abytPDCName() As Byte
Dim abytUserName() As Byte
Dim lngRet As Long
Dim i As Long
' Unicode
abytPDCName = fGetDCName() & vbNullChar
If (Len(strUserName) = 0) Then strUserName = GetUserName()
abytUserName = strUserName & vbNullChar
' Level 2
lngRet = apiNetUserGetInfo(abytPDCName(0), abytUserName(0), 2, pBuf)
If (lngRet = ERROR_SUCCESS) Then
Call sapiCopyMem(pTmp, ByVal pBuf, Len(pTmp))
GetUserFullName = fStrFromPtrW(pTmp.usri2_full_name)
End If
Call apiNetAPIBufferFree(pBuf)
ExitHere:
Exit Function
ErrHandler:
GetUserFullName = vbNullString
Resume ExitHere
End Function
Function GetUserName() As String
' Returns the network login name
Dim lngLen As Long, lngRet As Long
Dim strUserName As String
strUserName = String$(254, 0)
lngLen = 255
lngRet = apiGetUserName(strUserName, lngLen)
If lngRet Then
GetUserName = Left$(strUserName, lngLen - 1)
End If
End Function
Function fGetDCName() As String
Dim pTmp As Long
Dim lngRet As Long
Dim abytBuf() As Byte
lngRet = apiNetGetDCName(0, 0, pTmp)
If lngRet = 0 Then
fGetDCName = fStrFromPtrW(pTmp)
End If
Call apiNetAPIBufferFree(pTmp)
End Function
Function fStrFromPtrW(pBuf As Long) As String
Dim lngLen As Long
Dim abytBuf() As Byte
' Get the length of the string at the memory location
lngLen = apilstrlenW(pBuf) * 2
' if it's not a ZLS
If lngLen Then
ReDim abytBuf(lngLen)
' then copy the memory contents
' into a temp buffer
Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen)
' return the buffer
fStrFromPtrW = abytBuf
End If
End Function
Function CurUserName() As String
' returns the current logged in user
Dim sUser As String
Dim nBu As Long
Dim x As Variant
nBu = 8
sUser = Space(nBu)
x = wu_WNetGetUser(sUser, nBu)
sUser = Left(sUser, nBu - 1)
If IsNull(sUser) Then
MsgBox "Incorrect logon"
Else
CurUserName = sUser
End If
End Function
Function CurCompName() As String
' returns the current computers network id
Dim sComp As String
Dim nBu As Long
Dim x As Variant
nBu = 255
sComp = Space(nBu)
x = GetComputerName(sComp, nBu)
sComp = Left(sComp, InStr(sComp, vbNullChar) - 1)
If IsNull(sComp) Then
MsgBox "Incorrect logon"
Else
CurCompName = sComp
End If
End Function
Function GetHostAddr() As String
' returns the current computers network id
Dim ipAddress_h As Long ' the IP address, in host byte order
Dim ipAddress_n As Long ' the IP address, in network byte order
Dim sComp As String
Dim pHostinfo As Long
Dim nBu As Long
Dim x As Variant
ipAddress_n = htonl(ipAddress_h)
' Get information about the host computer.
pHostinfo = gethostbyaddr(ipAddress_n, 4, AF_INET)
'pHostinfo = Left(pHostinfo, InStr(pHostinfo, vbNullChar) - 1)
If IsNull(pHostinfo) Then
MsgBox "Incorrect logon"
Else
GetHostAddr = pHostinfo
End If
End Function
