Private Const WS_VERSION_REQD = &H101 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1 Private Const WSADescription_Len = 256 Private Const WSASYS_Status_Len = 128
Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type
Private Type WSADATA wversion As Integer wHighVersion As Integer szDescription(0 To WSADescription_Len) As Byte szSystemStatus(0 To WSASYS_Status_Len) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End Type
Declare Function wu_GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long Declare Function wu_GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long Private Declare Sub RtlMoveMemory Lib "kernel32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)
Function ap_GetComputerName() As Variant Dim strComputerName As String Dim lngLength As Long Dim lngResult As Long
strComputerName = String(255, 0) lngLength = 255
lngResult = wu_GetComputerName(strComputerName, lngLength) ap_GetComputerName = Left(strComputerName, InStr(1, strComputerName, Chr(0)) - 1)
End Function
Function ap_GetUserName() As Variant Dim strUserName As String Dim lngLength As Long Dim lngResult As Long
strUserName = String(255, 0) lngLength = 255
lngResult = wu_GetUserName(strUserName, lngLength) ap_GetUserName = Left(strUserName, InStr(1, strUserName, Chr(0)) - 1)
End Function Function GetComputerIP() As String Dim hostent_addr As Long Dim host As HOSTENT Dim hostip_addr As Long Dim temp_ip_address() As Byte Dim I As Integer Dim vntTemp As Variant
SocketsInitialize
hostent_addr = gethostbyname(vntTemp)
If hostent_addr = 0 Then MsgBox "Can't resolve name." Exit Function End If
RtlMoveMemory host, hostent_addr, LenB(host) RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength) RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For I = 1 To host.hLength GetComputerIP = GetComputerIP & temp_ip_address(I) & "." Next GetComputerIP = Mid$(GetComputerIP, 1, Len(GetComputerIP) - 1)
SocketsCleanup End Function
Function hibyte(ByVal wParam As Integer) hibyte = wParam \ &H100 And &HFF& End Function
Function lobyte(ByVal wParam As Integer) lobyte = wParam And &HFF& End Function
Sub SocketsInitialize()
Dim WSAD As WSADATA Dim iReturn As Integer Dim sLowByte As String, sHighByte As String, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then MsgBox "Winsock.dll is not responding." End End If
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then sHighByte = Trim$(Str$(hibyte(WSAD.wversion))) sLowByte = Trim$(Str$(lobyte(WSAD.wversion))) sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte sMsg = sMsg & " is not supported by winsock.dll " MsgBox sMsg End End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then sMsg = "This application requires a minimum of " sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets." MsgBox sMsg End End If
End Sub
Sub SocketsCleanup() Dim lReturn As Long
lReturn = WSACleanup()
If lReturn <> 0 Then MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup " End End If
End Sub
|