高手看看这代码哪里错了 `
Public Class Form2' Private type NETRESOURCE
Private Structure NETRESOURCE
Dim dwScope As Long
Dim dwType As Long
Dim dwDisplayType As Long
Dim dwUsage As Long
Dim lpLocalName As Long
Dim lpRemoteName As Long
Dim lpComment As Long
Dim lpProvider As Long
End Structure
'End Type
Private Structure HOSTENT
Dim hName As Long
Dim hAliases As Long
Dim hAddrType As Integer
Dim hLength As Integer
Dim hAddrList As Long
End Structure
' End Type
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128
Private Structure WSADATA
Dim wversion As Integer
Dim wHighVersion As Integer
Dim iMaxSockets As Integer
Dim iMaxUdpDg As Integer
Dim lpszVendorInfo As Long
End Structure
Dim szDescription(0 To WSADescription_Len) As Byte
Dim szSystemStatus(0 To WSASYS_Status_Len) As Byte
' 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, ByVal lpNetResource As Object, ByVal lphEnum As Long) As Long
Private Declare Function WNetEnumResource Lib "mpr.dll" Alias "WNetEnumResourceA" (ByVal hEnum As Long, ByVal lpcCount As Long, ByVal lpBuffer As Long, ByVal 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, ByVal 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" (ByVal Destination As Object, ByVal Source As Object, 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, lpBuffer + (lCount - 1) * Len(nr), Len(nr)) 'ByVal
' Debug.Print
PointerToString(nr.lpLocalName)
PointerToString(nr.lpRemoteName)
PointerToString(nr.lpProvider)
sName = PointerToString(nr.lpRemoteName)
If sName <> "" Then
sName = IIf(Strings.Left(sName, 2) = "\\", Strings.Right(sName, Len(sName) - 2), sName)
' List1.AddItem()
'List1.Text = sName & " ---- " & GetIP(sName)
List1.Items.Add(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
' End Sub
Private Function PointerToString(ByVal Addr As Long) As String
Dim str As String
str = (255, Chr(0))
CopyPointer2String(str, Addr)
PointerToString = Strings.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
GetIP = ""
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, lHostAddr, Len(host)) 'Byval
CopyMemory(lIPAddr, host.hAddrList, 4) 'Byval '获得IP地址
'ReDim bytIP(1 To host.hLength)
ReDim bytIP(0 To host.hLength)
CopyMemory(bytIP(1), lIPAddr, host.hLength) 'Byval
For lngX = 1 To host.hLength
GetIP = GetIP & bytIP(lngX) & "."
Next
GetIP = Strings.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 = Nothing
Dim sHighByte As String = Nothing
Dim sMsg As String = Nothing
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
Private Sub Button1_Click(ByVal sender As System.Object, ByVal e As System.EventArgs) Handles Button1.Click
GetComputer()
End Sub
End Class
这代码我是从VB6.0改过来的 但是出错了 提示 值不在范围内 哪位高手看看那个地方出错了 ` 谢谢
[[it] 本帖最后由 yz870735 于 2008-7-1 16:13 编辑 [/it]]
