怎样得到局域网中电脑的IP和主机名?? - VB6论坛

得分:0

改了一下。
Option Explicit
Private 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

Private Type HOSTENT
  hName As Long
  hAliases As Long
  hAddrType As Integer
  hLength As Integer
  hAddrList As Long
End Type

Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
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
'wnet API
Private Const NO_ERROR = 0
Private Const ERROR_NO_MORE_ITEMS = 259&
Private Const RESOURCE_CONTEXT = &H5
Private 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
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, lpcCount As Long, ByVal lpBuffer As Long, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long

'winsock API
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname As String) As Long
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 Declare Sub CopyMemory Lib "KERNEL32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Private Declare Function GlobalAlloc Lib "KERNEL32" (ByVal wFlags As Long, ByVal dwBytes As Long) As Long
Private Declare Function GlobalFree Lib "KERNEL32" (ByVal hMem As Long) As Long
Private Declare Function CopyPointer2String Lib "KERNEL32" Alias "lstrcpyA" (ByVal NewString As String, ByVal OldString As Long) As Long
Private Const GMEM_FIXED = &H0
Private Const GMEM_ZEROINIT = &H40
Private Const GPTR = (GMEM_FIXED Or GMEM_ZEROINIT)

Private Sub GetComputer()
Dim hEnum As Long
Dim lRetval As Long
Dim lpBufferSize As Long
Dim lpBuffer As Long
Dim lpcCount As Long
Dim nr As NETRESOURCE
Dim lCount As Long
Dim sName As String

lpBufferSize = 16 * 1024 '16K
lpcCount = &HFFFFFFFF '枚举所有资源
lpBuffer = GlobalAlloc(GPTR, lpBufferSize)
nr.dwUsage = 2                                                     '查找当前电脑所在的工作组
nr.lpRemoteName = 0                                                '查找当前电脑所在的工作组
lRetval = WNetOpenEnum(RESOURCE_CONTEXT, 0, 0, nr, hEnum)          '查找当前电脑所在的工作组
Do
If lRetval = NO_ERROR Then
lRetval = WNetEnumResource(hEnum, lpcCount, lpBuffer, lpBufferSize)
If lRetval = NO_ERROR Then
For lCount = 1 To lpcCount
CopyMemory nr, ByVal lpBuffer + (lCount - 1) * Len(nr), Len(nr) ' Debug.
Print PointerToString(nr.lpLocalName), PointerToString(nr.lpRemoteName), PointerToString(nr.lpProvider)
sName = PointerToString(nr.lpRemoteName)
If sName <> "" Then
sName = IIf(Left(sName, 2) = "\\", Right(sName, Len(sName) - 2), sName)
List1.AddItem sName & " ---- " & GetIP(sName)
End If
Next
End If
End If
Loop Until lRetval = ERROR_NO_MORE_ITEMS
GlobalFree (lpBuffer)
Call WNetCloseEnum(hEnum)
Call SocketsCleanup
End Sub

Private Sub Command1_Click()
GetComputer
End Sub

Private Function PointerToString(ByVal Addr As Long) As String
Dim str As String
str = String(255, Chr(0))
CopyPointer2String str, Addr
PointerToString = Left(str, InStr(str, Chr(0)) - 1)
End Function

Private Function GetIP(ByVal hostname As String) As String
Dim host As HOSTENT
Dim bytIP() As Byte
Dim lIPAddr As Long
Dim lHostAddr As Long
Dim lngX As Long
If Not SocketsInitialize Then
GetIP = "winsock.dll错误，无法获得IP"
Exit Function
End If
lHostAddr = gethostbyname(hostname)
If lHostAddr = 0 Then
GetIP = "未知错误，无法获得IP地址！"
Exit Function
End If
CopyMemory host, ByVal lHostAddr, Len(host)
CopyMemory lIPAddr, ByVal host.hAddrList, 4 '获得IP地址
ReDim bytIP(1 To host.hLength)
CopyMemory bytIP(1), ByVal lIPAddr, host.hLength
For lngX = 1 To host.hLength
GetIP = GetIP & bytIP(lngX) & "."
Next
GetIP = Left(GetIP, Len(GetIP) - 1)
End Function

Private Function SocketsInitialize() As Boolean '初始化winsock
Dim WSAD As WSADATA
Dim lRetval As Long
Dim sLowByte As String, sHighByte As String, sMsg As String
lRetval = WSAStartup(WS_VERSION_REQD, WSAD)
If lRetval <> 0 Then 'winsock.dll无响应
SocketsInitialize = False
Exit Function
End If '检查winsock版本
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then '当前版本不被支持
SocketsInitialize = False
Exit Function
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then 'winsock版本太低
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True

End Function

Function hibyte(ByVal wParam As Integer) As Integer
hibyte = wParam \ &H100 And &HFF&
End Function
Function lobyte(ByVal wParam As Integer) As Integer
lobyte = wParam And &HFF&
End Function

Sub SocketsCleanup() '中止winsock调用
Dim lRetval As Long
lRetval = WSACleanup()
If lRetval <> 0 Then
MsgBox "中止winsock时发生错误：" & lRetval
End If

End Sub