about usename

[jinvictor]

who kowns how to write a VBA to show users user name and ip address, window type in column a1?

[Peter Rooney]

Jinvictor,

MsgBox (Environ("UserName") & vbCrLf & Environ("ComputerName"))
for username and computername.

For IP address, I don't claim ANY credit for this, it goes to Rob Bovey, but
here it is (and there's a LOT of it!):

Cheers
Pete


Option Explicit

''' *************************************************************************
''' Module Constant Declaractions Follow
''' *************************************************************************
Private Const WSADescription_Len As Long = 256
Private Const WSASYS_Status_Len As Long = 128
Private Const WS_VERSION_REQD As Long = &H101
Private Const WS_VERSION_MAJOR As Long = WS_VERSION_REQD \ &H100 And &HFF
Private Const WS_VERSION_MINOR As Long = WS_VERSION_REQD And &HFF
Private Const MIN_SOCKETS_REQD As Long = 1


''' *************************************************************************
''' Module Type Declaractions Follow
''' *************************************************************************
''' An intermediate type structure required by various API calls to obtain
the IP address.
Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type

''' This type structure is required by the WSAStartup API.
Private Type WSADATA
wVersion As Integer ''' Low byte contains major version, High byte
contains minor version.
wHighVersion As Integer
bytDescription(0 To WSADescription_Len) As Byte
bytSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End Type


''' *************************************************************************
''' Module Variable Declarations Follow
''' *************************************************************************
''' It's critical for the Get IP Address procedure to trap for errors, but I
''' didn't want that to distract from the example, so I'm employing a very
''' rudimentary error handling scheme here. This variable is used to pass
error
''' messages between procedures.
Public gszErrMsg As String


''' *************************************************************************
''' Module DLL Declarations Follow
''' *************************************************************************
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal Hostname As
String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal
wVersionRequired As Long, ByRef lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Sub RtlMoveMemoryAny Lib "kernel32" Alias "RtlMoveMemory"
(ByRef hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub RtlMoveMemoryLong Lib "kernel32" Alias "RtlMoveMemory"
(ByRef hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As
String, ByRef nSize As Long) As Long


Public Sub DemoGetIPAddress()

Dim lIndex As Long
Dim szSuccessMsg As String
Dim aszIPAddresses() As String

If bGetIPAddresses(aszIPAddresses) Then
szSuccessMsg = "The IP address(es) assigned to this computer are:" &
vbLf
For lIndex = LBound(aszIPAddresses) To UBound(aszIPAddresses)
szSuccessMsg = szSuccessMsg & aszIPAddresses(lIndex)
Next lIndex
MsgBox szSuccessMsg, vbInformation, "Get IP Address Demo"
Else
MsgBox gszErrMsg, vbCritical, "Get IP Address Demo"
End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Returns the IP address(es) assigned to the current computer.
'''
''' Arguments: aszIPArray() [out] An uninitialized string array that will
''' be loaded with all of the IP addresses
assigned
''' to the computer this procedure is run on.
'''
''' NOTE: A computer can be assigned multiple IP
''' addresses. If you are sure the target computer
''' has only one IP address, simply use the first
''' element in this array.
'''
''' Returns: Boolean True on success, False on error.
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 05/20/05 Rob Bovey Created
'''
Public Function bGetIPAddresses(ByRef aszIPArray() As String) As Boolean

Dim bytTempBuffer() As Byte
Dim uHost As HOSTENT
Dim lStructPointer As Long
Dim lIPPointer As Long
Dim lNumIPs As Long
Dim lAddress As Long
Dim lOffset As Long
Dim lNumBytes As Long
Dim szHostName As String

On Error GoTo ErrorHandler

If Not bSocketsInitialize() Then Err.Raise 9999

''' Get the current computer name.
szHostName = szGetComputerName()

''' Get the memory location of the HOSTENT type structure.
lStructPointer = 0
lStructPointer = gethostbyname(szHostName)
If lStructPointer = 0 Then Err.Raise 9999, , "Winsock error: " &
CStr(WSAGetLastError())

''' Load the HOSTENT type structure variable.
RtlMoveMemoryAny uHost, lStructPointer, LenB(uHost)

''' Get the memory location of the IP address.
RtlMoveMemoryLong lIPPointer, uHost.hAddrList, 4

''' Get the length of the IP Address list.
''' This works experimentally, I'm not sure if this is by accident or by
design.
lNumBytes = uHost.hName - lIPPointer ''' It appears like uHost.hName
begins at the memory address right after the last IP list address.
lNumIPs = lNumBytes / 4 ''' Each IP address is 4 bytes
long
ReDim bytTempBuffer(1 To lNumBytes)
ReDim aszIPArray(1 To lNumIPs)

''' Load the IP address into our byte buffer.
RtlMoveMemoryAny bytTempBuffer(1), lIPPointer, lNumBytes

lOffset = 0
For lAddress = 1 To lNumIPs
''' Each item in the byte array will be one of the octets in the IP
address.
aszIPArray(lAddress) = bytTempBuffer(1 + lOffset) & "." &
bytTempBuffer(2 + lOffset) & "." & bytTempBuffer(3 + lOffset) & "." &
bytTempBuffer(4 + lOffset)
lOffset = lOffset + 4
Next lAddress

''' Clean up the Winsock session.
WSACleanup

bGetIPAddresses = True
Exit Function

ErrorHandler:
If Len(gszErrMsg) = 0 Then gszErrMsg = Err.Description
If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (bGetIPAddresses)"
bGetIPAddresses = False
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Initializes the Winsock session. This function must be called
''' before any other Winsock APIs are used.
'''
''' Returns: Boolean True on success, False on error.
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 05/20/05 Rob Bovey Created
'''
Private Function bSocketsInitialize() As Boolean

Dim iVersion As Integer
Dim lReturn As Long
Dim uWinsockDetail As WSADATA

On Error GoTo ErrorHandler

''' Call the Winsock startup API.
lReturn = WSAStartup(WS_VERSION_REQD, uWinsockDetail)
If lReturn <> 0 Then Err.Raise 9999, , "WSAStartup error: " &
CStr(lReturn)

iVersion = uWinsockDetail.wVersion

If LowByte(iVersion) < WS_VERSION_MAJOR Or (LowByte(iVersion) =
WS_VERSION_MAJOR And HighByte(iVersion) < WS_VERSION_MINOR) Then
Err.Raise 9999, , "Required sockets version not supported by
existing winsock.dll."
ElseIf uWinsockDetail.iMaxSockets < MIN_SOCKETS_REQD Then
Err.Raise 9999, , "Required sockets version not supported by
existing winsock.dll."
End If

bSocketsInitialize = True
Exit Function

ErrorHandler:
If Len(gszErrMsg) = 0 Then gszErrMsg = Err.Description
If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (bSocketsInitialize)"
''' Clean up the Winsock session.
WSACleanup
bSocketsInitialize = False
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments: Returns the NETBIOS name of the current computer.
'''
''' Returns: String The name of the computer, or an empty string on
''' error.
'''
''' Date Developer Action
''' --------------------------------------------------------------------------
''' 05/20/05 Rob Bovey Created
'''
Public Function szGetComputerName() As String

Dim lReturn As Long
Dim lLength As Long
Dim szNameBuffer As String

On Error GoTo ErrorHandler

''' Initialize variables.
lLength = 255
szNameBuffer = String$(lLength, vbNullChar)

''' Call the API function.
lReturn = GetComputerNameA(szNameBuffer, lLength)
If lReturn = 0 Then Err.Raise 9999

''' Strip out and return the computer name.
szGetComputerName = Left$(szNameBuffer, lLength)
Exit Function

ErrorHandler:
gszErrMsg = Err.Description
If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (szGetComputerName)"
szGetComputerName = vbNullString
End Function


''' Retrieve the high byte from the specifed integer argument.
Private Function HighByte(ByVal iNum As Integer) As Integer
HighByte = iNum \ &H100 And &HFF
End Function


''' Retrieve the low byte from the specifed integer argument.
Private Function LowByte(ByVal iNum As Integer) As Integer
LowByte = iNum And &HFF
End Function

[NickHK]

Alternative on the IP address is to read the registry:
http://www.codeproject.com/vbscript/...&select=758178

NickHK

"jinvictor" <jinvictor.29su80_1150972208.5752@excelforum-nospam.com> wrote
in message news:jinvictor.29su80_1150972208.5752@excelforum-nospam.com...
>
> who kowns how to write a VBA to show users user name and ip address,
> window type in column a1?
>
>
> --
> jinvictor
> ------------------------------------------------------------------------
> jinvictor's Profile:
http://www.excelforum.com/member.php...o&userid=34099
> View this thread: http://www.excelforum.com/showthread...hreadid=554470
>