'Win98 and VB6
'This will get the network name and all computers and their IPs, that are 'booted to the LAN
'Paste this into a module
Option Explicit
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 ip_address As String
Dim strWinsockNotResponding As Long
Public Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
lpLocalName As Long
lpRemoteName As Long
lpComment As Long
lpProvider As Long
End Type
Public Declare Function WNetOpenEnum Lib "mpr.dll" Alias _
"WNetOpenEnumA" ( _
ByVal dwScope As Long, _
ByVal dwType As Long, _
ByVal dwUsage As Long, _
lpNetResource As Any, _
lphEnum As Long) As Long
Public Declare Function WNetEnumResource Lib "mpr.dll" Alias _
"WNetEnumResourceA" ( _
ByVal hEnum As Long, _
lpcCount As Long, _
ByVal lpBuffer As Long, _
lpBufferSize As Long) As Long
Public Declare Function WNetCloseEnum Lib "mpr.dll" ( _
ByVal hEnum As Long) As Long
'RESOURCE ENUMERATION.
Public Const RESOURCE_CONNECTED = &H1
Public Const RESOURCE_GLOBALNET = &H2
Public Const RESOURCE_REMEMBERED = &H3
Public Const RESOURCETYPE_ANY = &H0
Public Const RESOURCETYPE_DISK = &H1
Public Const RESOURCETYPE_PRINT = &H2
Public Const RESOURCETYPE_UNKNOWN = &HFFFF
Public Const RESOURCEUSAGE_CONNECTABLE = &H1
Public Const RESOURCEUSAGE_CONTAINER = &H2
Public Const RESOURCEUSAGE_RESERVED = &H80000000
Public Const GMEM_FIXED = &H0
Public Const GMEM_ZEROINIT = &H40
Public Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)
Public Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Public Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
Public Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (hpvDest As Any, hpvSource As Any, ByVal cbCopy As Long)
Public Declare Function CopyPointer2String Lib "KERNEL32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Public Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Public Const WS_VERSION_REQD = &H101
Public Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Public Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Public Const MIN_SOCKETS_REQD = 1
Public Const SOCKET_ERROR = -1
Public Const WSADescription_Len = 256
Public Const WSASYS_Status_Len = 128
Public Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End Type
Public 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
Public Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Public Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, _
lpWSAData As WSADATA) As Long
Public Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
Public Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal _
hpvSource&, ByVal cbCopy As Long)
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 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
Public Function GetIPHostName(sHostName$) As String
If Not SocketsInitialize Then
GetIPHostName = ""
Exit Function
End If
GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
SocketsCleanup
End Function
Public Sub DoNetEnum()
Dim hEnum As Long, lpBuff As Long, NR As NETRESOURCE
Dim cbBuff As Long, cCount As Long
Dim p As Long, res As Long, i As Long
'Setup the NETRESOURCE input structure.
NR.lpRemoteName = 0
cbBuff = 10000
cCount = &HFFFFFFFF
'Open a Net enumeration operation handle: hEnum.
res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, NR, hEnum)
If res = 0 Then
'Create a buffer large enough for the results.
'10000 bytes should be sufficient.
lpBuff = GlobalAlloc(GPTR, cbBuff)
'Call the enumeration function.
res = WNetEnumResource(hEnum, cCount, lpBuff, cbBuff)
If res = 0 Then
p = lpBuff
'WNetEnumResource fills the buffer with an array of
'NETRESOURCE structures. Walk through the list and list
'each local and remote name.
For i = 1 To cCount
' All we get back are the Global Network Containers --- Enumerate each of these
CopyMemory NR, ByVal p, LenB(NR)
Form1.Show
Form1.List1.AddItem "Network Name " & PointerToString(NR.lpRemoteName)
DoNetEnum2 NR
p = p + LenB(NR)
Next i
End If
If lpBuff <> 0 Then GlobalFree (lpBuff)
WNetCloseEnum (hEnum) 'Close the enumeration
End If
End Sub
Public Function PointerToString(p As Long) As String
'The values returned in the NETRESOURCE structures are pointers to
'ANSI strings so they need to be converted to Visual Basic Strings.
Dim s As String
s = String(255, Chr$(0))
CopyPointer2String s, p
PointerToString = Left(s, InStr(s, Chr$(0)) - 1)
End Function
Public Sub DoNetEnum2(NR As NETRESOURCE)
Dim hEnum As Long, lpBuff As Long
Dim cbBuff As Long, cCount As Long
Dim p As Long, res As Long, i As Long
'Setup the NETRESOURCE input structure.
cbBuff = 10000
cCount = &HFFFFFFFF
'Open a Net enumeration operation handle: hEnum.
res = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, 0, NR, hEnum)
If res = 0 Then
'Create a buffer large enough for the results.
'10000 bytes should be sufficient.
lpBuff = GlobalAlloc(GPTR, cbBuff)
'Call the enumeration function.
res = WNetEnumResource(hEnum, cCount, lpBuff, cbBuff)
If res = 0 Then
p = lpBuff
'WNetEnumResource fills the buffer with an array of
'NETRESOURCE structures. Walk through the list and print
'each remote name.
For i = 1 To cCount
CopyMemory NR, ByVal p, LenB(NR)
ip_address = ""
GetIPNums (PointerToString(NR.lpRemoteName))
Form1.List1.AddItem "Network Computer #" & i & " " & PointerToString(NR.lpRemoteName) & vbTab & "IP: " & ip_address
p = p + LenB(NR)
Next i
End If
If lpBuff <> 0 Then GlobalFree (lpBuff)
WNetCloseEnum (hEnum) 'Close the enumeration
End If
End Sub
Public Function GetIPNums(Compname)
hostent_addr = gethostbyname(Mid(Compname, 3))
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
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
End Function
Public Function SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte, sHighByte, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then
SocketsInitialize = strWinsockNotResponding
Exit Function
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)))
SocketsInitialize = "Windows Sockets version " & sLowByte & "." & sHighByte & _
" is not supported by winsock.dll "
Exit Function
End If
'iMaxSockets is not used in winsock 2. So the following check is only
'necessary for winsock 1. If winsock 2 is requested,
'the following check can be skipped.
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
SocketsInitialize = "This application requires a minimum of " & _
Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
Exit Function
End If
SocketsInitialize = ""
End Function
'Put this on a form with a list1 and a Winsock1 and a Command1
Private Sub Form_Unload(Cancel As Integer)
SocketsCleanup
End Sub
Private Sub Command1_Click()
Me.Left = (Screen.Width - Me.Width) / 2
Me.Top = (Screen.Height - Me.Height) / 2
DoNetEnum
SocketsInitialize
End Sub
