首页上一页 1 下一页尾页 1 条记录 1/1页
《Visual Basic程序开发范例宝典》
发表在VB答疑区
2009-07-07
是否精华
是
否
版块置顶:
是
否
只是随便举个例子,看看你的技术和态度。
范例442:
[Form11]代码,请运行一下
VERSION 5.00
Begin VB.Form Form11
Caption = "获取局域网计算机名称和IP"
ClientHeight = 2550
ClientLeft = 60
ClientTop = 345
ClientWidth = 4890
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 2550
ScaleWidth = 4890
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame2
Height = 900
Left = 2190
TabIndex = 1
Top = 0
Width = 2655
Begin VB.TextBox TxtCmpName
Height = 315
Left = 810
TabIndex = 3
Top = 150
Width = 1740
End
Begin VB.TextBox TxtIp
Height = 315
Left = 810
TabIndex = 2
Top = 495
Width = 1725
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "机器名:"
Height = 180
Left = 75
TabIndex = 5
Top = 195
Width = 720
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Ip地址:"
Height = 180
Left = 60
TabIndex = 4
Top = 510
Width = 885
End
End
Begin VB.ListBox List1
Height = 2220
Left = 90
TabIndex = 0
Top = 225
Width = 1965
End
Begin VB.Frame Frame1
Caption = "局域网中的计算机"
Height = 2550
Left = 0
TabIndex = 6
Top = 0
Width = 2145
End
Begin VB.Image Image1
Height = 1530
Left = 2205
Picture = "Form11.frx":0000
Stretch = -1 'True
Top = 960
Width = 2610
End
End
Attribute VB_Name = "Form11"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Const RESOURCE_GLOBALNET As Long = &H2& ' 枚举所有资源
' 网络资源类型常数
Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
sLocalName As String
sRemoteName As String
sComment As String
sProvider As String
End Type
Private Type NETRESOURCE_BUF
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
pLocalName As Long
pRemoteName As Long
pComment As Long
pProvider As Long
End Type
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
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 Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Sub Form_Load()
On Error Resume Next
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1
Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE
bFirstTime = True
Do
If bFirstTime Then
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
bFirstTime = False
Else
If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
Else
lReturn = NOT_A_CONTAINER
hEnum = 0
End If
lLastIndex = lLastIndex + 1
End If
If lReturn = NO_ERROR Then
lCount = RESOURCE_ENUM_ALL
Do
lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
If lCount > 0 Then
ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
For l = 0 To lCount - 1
uNet(lMin + l).dwScope = uNetApi(l).dwScope
uNet(lMin + l).dwType = uNetApi(l).dwType
uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
If uNetApi(l).pLocalName Then
lLength = lstrlen(uNetApi(l).pLocalName)
uNet(lMin + l).sLocalName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
End If
If uNetApi(l).pRemoteName Then
lLength = lstrlen(uNetApi(l).pRemoteName)
uNet(lMin + l).sRemoteName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
End If
Next l
End If
lMin = lMin + lCount
Loop While lReturn = ERROR_MORE_DATA
End If
If hEnum Then l = WNetCloseEnum(hEnum)
Loop While lLastIndex < lMin
If UBound(uNet) > 0 Then
For l = 0 To UBound(uNet)
If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then List1.AddItem uNet(l).sRemoteName
Next l
End If
End Sub
Private Sub List1_Click()
On Error Resume Next
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
Dim mystr As String
mystr = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))
Screen.MousePointer = vbHourglass
If TxtCmpName = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = ""
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(TxtCmpName) & Chr$(0)
End If
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = ""
If WSACleanup() <> ERROR_SUCCESS Then App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
End Sub
[工程1.vbp]
内容:
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\System32\stdole2.tlb#OLE Automation
Form=Form11.frm '此处改为Form1.frm
Startup="Form11" '此处改为"Form1"稍微好点
HelpFile=""
ExeName32="获取局域网计算机名称和IP.exe"
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
【Form1.frm】比Form11.frm稍微好点,但是同样会报错:变量GetIPAddress未定义,无论跳过还是声明然后还会报告别的错误。
内容:
VERSION 5.00
Begin VB.Form Form1
Caption = "获取局域网计算机名称和IP"
ClientHeight = 2550
ClientLeft = 60
ClientTop = 345
ClientWidth = 4890
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 2550
ScaleWidth = 4890
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame2
Height = 900
Left = 2190
TabIndex = 1
Top = 0
Width = 2655
Begin VB.TextBox TxtCmpName
Height = 315
Left = 810
TabIndex = 3
Top = 150
Width = 1740
End
Begin VB.TextBox TxtIp
Height = 315
Left = 810
TabIndex = 2
Top = 495
Width = 1725
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "机器名:"
Height = 180
Left = 75
TabIndex = 5
Top = 195
Width = 720
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Ip地址:"
Height = 180
Left = 60
TabIndex = 4
Top = 510
Width = 885
End
End
Begin VB.ListBox List1
Height = 2220
Left = 90
TabIndex = 0
Top = 225
Width = 1965
End
Begin VB.Frame Frame1
Caption = "局域网中的计算机"
Height = 2550
Left = 0
TabIndex = 6
Top = 0
Width = 2145
End
Begin VB.Image Image1
Height = 1530
Left = 2205
Picture = "Form1.frx":0000
Stretch = -1 'True
Top = 960
Width = 2610
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Const RESOURCE_GLOBALNET As Long = &H2& ' 枚举所有资源
' 网络资源类型常数
Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
sLocalName As String
sRemoteName As String
sComment As String
sProvider As String
End Type
Private Type NETRESOURCE_BUF
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
pLocalName As Long
pRemoteName As Long
pComment As Long
pProvider As Long
End Type
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
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 Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
' 初始化Socket
Private Function SocketsInitialize(Optional sErr As String) As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
' 初始化Winsock DLL,并判断版本是否满足要求
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
sErr = "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
' 判断是否有支持足够的Socket
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
sErr = "This application requires a minimum of " & _
CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
' 判断Winsock的版本是否被32为Winsock支持
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
sErr = "Sockets version " & sLoByte & "." & sHiByte & _
" is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
' 释放Socket库所占用的系统资源
Private Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
End Sub
' 获得一个整数的高字节位
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H1 And &HFF&
End Function
' 获得一个整数的低字节位
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
' 用于获得网上邻居计算机名称的子程序
Sub GetNeighbor()
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1
Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE
bFirstTime = True
Do
If bFirstTime Then
' 启动对顶级网络资源进行枚举的过程,并返回枚举资源所用的句柄
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
bFirstTime = False
Else
' 如果uNet(lLastIndex)资源包含了可以枚举的额外资源,并返回枚举资源所用的句柄
If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
' 启动对包含于指定资源内的资源的枚举
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
Else '否则
lReturn = NOT_A_CONTAINER
hEnum = 0
End If
' 下一个资源
lLastIndex = lLastIndex + 1
End If
If lReturn = NO_ERROR Then '如果返回值表示成功
lCount = RESOURCE_ENUM_ALL
Do
' 设置缓冲区大小
lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
' 应用上面WNetOpenEnum返回的句柄枚举网络资源,并将枚举信息装载到uNetApi缓冲区
lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
If lCount > 0 Then
' 为动态数组变量重新分配存储空间
ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
For l = 0 To lCount - 1
'将枚举信息赋值给 uNet
uNet(lMin + l).dwScope = uNetApi(l).dwScope
uNet(lMin + l).dwType = uNetApi(l).dwType
uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
' 对于以下的值通过内存复制的方式赋值
If uNetApi(l).pLocalName Then
lLength = lstrlen(uNetApi(l).pLocalName)
uNet(lMin + l).sLocalName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
End If
If uNetApi(l).pRemoteName Then
lLength = lstrlen(uNetApi(l).pRemoteName)
uNet(lMin + l).sRemoteName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
End If
If uNetApi(l).pComment Then
lLength = lstrlen(uNetApi(l).pComment)
uNet(lMin + l).sComment = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
End If
If uNetApi(l).pProvider Then
lLength = lstrlen(uNetApi(l).pProvider)
uNet(lMin + l).sProvider = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
End If
Next l
End If
lMin = lMin + lCount
Loop While lReturn = ERROR_MORE_DATA
End If
If hEnum Then
' 结束枚举操作
l = WNetCloseEnum(hEnum)
End If
Loop While lLastIndex < lMin
If UBound(uNet) > 0 Then
For l = 0 To UBound(uNet)
' 判断资源类型,并将网上邻居显示出来
If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then
List1.AddItem uNet(l).sRemoteName
End If
Next l
End If
End Sub
Private Sub Form_Load()
GetNeighbor
End Sub
Private Sub List1_Click()
TxtCmpName = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))
On Error Resume Next
Screen.MousePointer = vbHourglass
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If TxtCmpName = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(TxtCmpName) & Chr$(0)
End If
' 获得指向主机信息结构的指针
lpHost = gethostbyname(sHostName)
' 如果指针为零,则错误退出
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
' 从指定内存取得数据
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
' 重新动态分配变量内存
ReDim tmpIPAddr(1 To HOST.hLen)
' 将主机地址存储到tmpIPAddr中
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
' 获得最终的主机IP地址字符串
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
' 返回
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
Screen.MousePointer = vbDefault
End Function
范例442:
[Form11]代码,请运行一下
VERSION 5.00
Begin VB.Form Form11
Caption = "获取局域网计算机名称和IP"
ClientHeight = 2550
ClientLeft = 60
ClientTop = 345
ClientWidth = 4890
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 2550
ScaleWidth = 4890
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame2
Height = 900
Left = 2190
TabIndex = 1
Top = 0
Width = 2655
Begin VB.TextBox TxtCmpName
Height = 315
Left = 810
TabIndex = 3
Top = 150
Width = 1740
End
Begin VB.TextBox TxtIp
Height = 315
Left = 810
TabIndex = 2
Top = 495
Width = 1725
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "机器名:"
Height = 180
Left = 75
TabIndex = 5
Top = 195
Width = 720
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Ip地址:"
Height = 180
Left = 60
TabIndex = 4
Top = 510
Width = 885
End
End
Begin VB.ListBox List1
Height = 2220
Left = 90
TabIndex = 0
Top = 225
Width = 1965
End
Begin VB.Frame Frame1
Caption = "局域网中的计算机"
Height = 2550
Left = 0
TabIndex = 6
Top = 0
Width = 2145
End
Begin VB.Image Image1
Height = 1530
Left = 2205
Picture = "Form11.frx":0000
Stretch = -1 'True
Top = 960
Width = 2610
End
End
Attribute VB_Name = "Form11"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Const RESOURCE_GLOBALNET As Long = &H2& ' 枚举所有资源
' 网络资源类型常数
Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
sLocalName As String
sRemoteName As String
sComment As String
sProvider As String
End Type
Private Type NETRESOURCE_BUF
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
pLocalName As Long
pRemoteName As Long
pComment As Long
pProvider As Long
End Type
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
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 Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
Private Sub Form_Load()
On Error Resume Next
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1
Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE
bFirstTime = True
Do
If bFirstTime Then
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
bFirstTime = False
Else
If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
Else
lReturn = NOT_A_CONTAINER
hEnum = 0
End If
lLastIndex = lLastIndex + 1
End If
If lReturn = NO_ERROR Then
lCount = RESOURCE_ENUM_ALL
Do
lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
If lCount > 0 Then
ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
For l = 0 To lCount - 1
uNet(lMin + l).dwScope = uNetApi(l).dwScope
uNet(lMin + l).dwType = uNetApi(l).dwType
uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
If uNetApi(l).pLocalName Then
lLength = lstrlen(uNetApi(l).pLocalName)
uNet(lMin + l).sLocalName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
End If
If uNetApi(l).pRemoteName Then
lLength = lstrlen(uNetApi(l).pRemoteName)
uNet(lMin + l).sRemoteName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
End If
Next l
End If
lMin = lMin + lCount
Loop While lReturn = ERROR_MORE_DATA
End If
If hEnum Then l = WNetCloseEnum(hEnum)
Loop While lLastIndex < lMin
If UBound(uNet) > 0 Then
For l = 0 To UBound(uNet)
If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then List1.AddItem uNet(l).sRemoteName
Next l
End If
End Sub
Private Sub List1_Click()
On Error Resume Next
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
Dim mystr As String
mystr = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))
Screen.MousePointer = vbHourglass
If TxtCmpName = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = ""
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(TxtCmpName) & Chr$(0)
End If
lpHost = gethostbyname(sHostName)
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = ""
If WSACleanup() <> ERROR_SUCCESS Then App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
Exit Function
End If
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
ReDim tmpIPAddr(1 To HOST.hLen)
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
End Sub
[工程1.vbp]
内容:
Type=Exe
Reference=*\G{00020430-0000-0000-C000-000000000046}#2.0#0#C:\WINDOWS\System32\stdole2.tlb#OLE Automation
Form=Form11.frm '此处改为Form1.frm
Startup="Form11" '此处改为"Form1"稍微好点
HelpFile=""
ExeName32="获取局域网计算机名称和IP.exe"
Command32=""
Name="工程1"
HelpContextID="0"
CompatibleMode="0"
MajorVer=1
MinorVer=0
RevisionVer=0
AutoIncrementVer=0
ServerSupportFiles=0
CompilationType=0
OptimizationType=0
FavorPentiumPro(tm)=0
CodeViewDebugInfo=0
NoAliasing=0
BoundsCheck=0
OverflowCheck=0
FlPointCheck=0
FDIVCheck=0
UnroundedFP=0
StartMode=0
Unattended=0
Retained=0
ThreadPerObject=0
MaxNumberOfThreads=1
[MS Transaction Server]
AutoRefresh=1
【Form1.frm】比Form11.frm稍微好点,但是同样会报错:变量GetIPAddress未定义,无论跳过还是声明然后还会报告别的错误。
内容:
VERSION 5.00
Begin VB.Form Form1
Caption = "获取局域网计算机名称和IP"
ClientHeight = 2550
ClientLeft = 60
ClientTop = 345
ClientWidth = 4890
LinkTopic = "Form1"
LockControls = -1 'True
MaxButton = 0 'False
ScaleHeight = 2550
ScaleWidth = 4890
StartUpPosition = 2 '屏幕中心
Begin VB.Frame Frame2
Height = 900
Left = 2190
TabIndex = 1
Top = 0
Width = 2655
Begin VB.TextBox TxtCmpName
Height = 315
Left = 810
TabIndex = 3
Top = 150
Width = 1740
End
Begin VB.TextBox TxtIp
Height = 315
Left = 810
TabIndex = 2
Top = 495
Width = 1725
End
Begin VB.Label Label1
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "机器名:"
Height = 180
Left = 75
TabIndex = 5
Top = 195
Width = 720
End
Begin VB.Label Label2
AutoSize = -1 'True
BackStyle = 0 'Transparent
Caption = "Ip地址:"
Height = 180
Left = 60
TabIndex = 4
Top = 510
Width = 885
End
End
Begin VB.ListBox List1
Height = 2220
Left = 90
TabIndex = 0
Top = 225
Width = 1965
End
Begin VB.Frame Frame1
Caption = "局域网中的计算机"
Height = 2550
Left = 0
TabIndex = 6
Top = 0
Width = 2145
End
Begin VB.Image Image1
Height = 1530
Left = 2205
Picture = "Form1.frx":0000
Stretch = -1 'True
Top = 960
Width = 2610
End
End
Attribute VB_Name = "Form1"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False
Option Explicit
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, lpBuffer As Any, lpBufferSize As Long) As Long
Private Declare Function WNetCloseEnum Lib "mpr.dll" (ByVal hEnum As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (lpTo As Any, lpFrom As Any, ByVal lLen As Long)
Private Declare Function lstrcpy Lib "kernel32" Alias "lstrcpyA" (ByVal lpString1 As String, ByVal lpString2 As Any) As Long
Private Declare Function lstrlen Lib "kernel32" Alias "lstrlenA" (ByVal lpString As Any) As Long
Private Const RESOURCE_GLOBALNET As Long = &H2& ' 枚举所有资源
' 网络资源类型常数
Private Const RESOURCEDISPLAYTYPE_DIRECTORY& = &H9
Private Const RESOURCEDISPLAYTYPE_DOMAIN& = &H1
Private Const RESOURCEDISPLAYTYPE_FILE& = &H4
Private Const RESOURCEDISPLAYTYPE_GENERIC& = &H0
Private Const RESOURCEDISPLAYTYPE_GROUP& = &H5
Private Const RESOURCEDISPLAYTYPE_NETWORK& = &H6
Private Const RESOURCEDISPLAYTYPE_ROOT& = &H7
Private Const RESOURCEDISPLAYTYPE_SERVER& = &H2
Private Const RESOURCEDISPLAYTYPE_SHARE& = &H3
Private Const RESOURCEDISPLAYTYPE_SHAREADMIN& = &H8
Private Const RESOURCETYPE_ANY As Long = &H0&
Private Const RESOURCETYPE_DISK As Long = &H1&
Private Const RESOURCETYPE_PRINT As Long = &H2&
Private Const RESOURCETYPE_UNKNOWN As Long = &HFFFF&
Private Const RESOURCEUSAGE_ALL As Long = &H0&
Private Const RESOURCEUSAGE_CONNECTABLE As Long = &H1&
Private Const RESOURCEUSAGE_CONTAINER As Long = &H2&
Private Const RESOURCEUSAGE_RESERVED As Long = &H80000000
Private Const NO_ERROR = 0
Private Const ERROR_MORE_DATA = 234
Private Const RESOURCE_ENUM_ALL As Long = &HFFFF
Private Type NETRESOURCE
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
sLocalName As String
sRemoteName As String
sComment As String
sProvider As String
End Type
Private Type NETRESOURCE_BUF
dwScope As Long
dwType As Long
dwDisplayType As Long
dwUsage As Long
pLocalName As Long
pRemoteName As Long
pComment As Long
pProvider As Long
End Type
Private Declare Function gethostname Lib "WSOCK32.DLL" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal szHost As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Const SOCKET_ERROR As Long = -1
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128
Private Const ERROR_SUCCESS As Long = 0
Private Const WS_VERSION_REQD As Long = &H101
Private Const MIN_SOCKETS_REQD As Long = 1
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 Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLen As Integer
hAddrList As Long
End Type
Private Type WSADATA
wVersion As Integer
wHighVersion As Integer
szDescription(0 To MAX_WSADescription) As Byte
szSystemStatus(0 To MAX_WSASYSStatus) As Byte
wMaxSockets As Integer
wMaxUDPDG As Integer
dwVendorInfo As Long
End Type
' 初始化Socket
Private Function SocketsInitialize(Optional sErr As String) As Boolean
Dim WSAD As WSADATA
Dim sLoByte As String
Dim sHiByte As String
' 初始化Winsock DLL,并判断版本是否满足要求
If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
sErr = "The 32-bit Windows Socket is not responding."
SocketsInitialize = False
Exit Function
End If
' 判断是否有支持足够的Socket
If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
sErr = "This application requires a minimum of " & _
CStr(MIN_SOCKETS_REQD) & " supported sockets."
SocketsInitialize = False
Exit Function
End If
' 判断Winsock的版本是否被32为Winsock支持
If LoByte(WSAD.wVersion) < WS_VERSION_MAJOR Or _
(LoByte(WSAD.wVersion) = WS_VERSION_MAJOR And _
HiByte(WSAD.wVersion) < WS_VERSION_MINOR) Then
sHiByte = CStr(HiByte(WSAD.wVersion))
sLoByte = CStr(LoByte(WSAD.wVersion))
sErr = "Sockets version " & sLoByte & "." & sHiByte & _
" is not supported by 32-bit Windows Sockets."
SocketsInitialize = False
Exit Function
End If
SocketsInitialize = True
End Function
' 释放Socket库所占用的系统资源
Private Sub SocketsCleanup()
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
End Sub
' 获得一个整数的高字节位
Private Function HiByte(ByVal wParam As Integer)
HiByte = wParam \ &H1 And &HFF&
End Function
' 获得一个整数的低字节位
Private Function LoByte(ByVal wParam As Integer)
LoByte = wParam And &HFF&
End Function
' 用于获得网上邻居计算机名称的子程序
Sub GetNeighbor()
Const MAX_RESOURCES = 256
Const NOT_A_CONTAINER = -1
Dim bFirstTime As Boolean
Dim lReturn As Long
Dim hEnum As Long
Dim lCount As Long
Dim lMin As Long
Dim lLength As Long
Dim l As Long
Dim lBufferSize As Long
Dim lLastIndex As Long
Dim uNetApi(0 To MAX_RESOURCES) As NETRESOURCE_BUF
Dim uNet() As NETRESOURCE
bFirstTime = True
Do
If bFirstTime Then
' 启动对顶级网络资源进行枚举的过程,并返回枚举资源所用的句柄
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, ByVal 0&, hEnum)
bFirstTime = False
Else
' 如果uNet(lLastIndex)资源包含了可以枚举的额外资源,并返回枚举资源所用的句柄
If uNet(lLastIndex).dwUsage And RESOURCEUSAGE_CONTAINER Then
' 启动对包含于指定资源内的资源的枚举
lReturn = WNetOpenEnum(RESOURCE_GLOBALNET, RESOURCETYPE_ANY, RESOURCEUSAGE_ALL, uNet(lLastIndex), hEnum)
Else '否则
lReturn = NOT_A_CONTAINER
hEnum = 0
End If
' 下一个资源
lLastIndex = lLastIndex + 1
End If
If lReturn = NO_ERROR Then '如果返回值表示成功
lCount = RESOURCE_ENUM_ALL
Do
' 设置缓冲区大小
lBufferSize = UBound(uNetApi) * Len(uNetApi(0)) / 2
' 应用上面WNetOpenEnum返回的句柄枚举网络资源,并将枚举信息装载到uNetApi缓冲区
lReturn = WNetEnumResource(hEnum, lCount, uNetApi(0), lBufferSize)
If lCount > 0 Then
' 为动态数组变量重新分配存储空间
ReDim Preserve uNet(0 To lMin + lCount - 1) As NETRESOURCE
For l = 0 To lCount - 1
'将枚举信息赋值给 uNet
uNet(lMin + l).dwScope = uNetApi(l).dwScope
uNet(lMin + l).dwType = uNetApi(l).dwType
uNet(lMin + l).dwDisplayType = uNetApi(l).dwDisplayType
uNet(lMin + l).dwUsage = uNetApi(l).dwUsage
' 对于以下的值通过内存复制的方式赋值
If uNetApi(l).pLocalName Then
lLength = lstrlen(uNetApi(l).pLocalName)
uNet(lMin + l).sLocalName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sLocalName, ByVal uNetApi(l).pLocalName, lLength
End If
If uNetApi(l).pRemoteName Then
lLength = lstrlen(uNetApi(l).pRemoteName)
uNet(lMin + l).sRemoteName = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sRemoteName, ByVal uNetApi(l).pRemoteName, lLength
End If
If uNetApi(l).pComment Then
lLength = lstrlen(uNetApi(l).pComment)
uNet(lMin + l).sComment = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sComment, ByVal uNetApi(l).pComment, lLength
End If
If uNetApi(l).pProvider Then
lLength = lstrlen(uNetApi(l).pProvider)
uNet(lMin + l).sProvider = Space$(lLength)
CopyMem ByVal uNet(lMin + l).sProvider, ByVal uNetApi(l).pProvider, lLength
End If
Next l
End If
lMin = lMin + lCount
Loop While lReturn = ERROR_MORE_DATA
End If
If hEnum Then
' 结束枚举操作
l = WNetCloseEnum(hEnum)
End If
Loop While lLastIndex < lMin
If UBound(uNet) > 0 Then
For l = 0 To UBound(uNet)
' 判断资源类型,并将网上邻居显示出来
If uNet(l).dwDisplayType = RESOURCEDISPLAYTYPE_SERVER Then
List1.AddItem uNet(l).sRemoteName
End If
Next l
End If
End Sub
Private Sub Form_Load()
GetNeighbor
End Sub
Private Sub List1_Click()
TxtCmpName = Mid(List1.List(List1.ListIndex), 3, Len(List1.List(List1.ListIndex)))
On Error Resume Next
Screen.MousePointer = vbHourglass
Dim sHostName As String * 256
Dim lpHost As Long
Dim HOST As HOSTENT
Dim dwIPAddr As Long
Dim tmpIPAddr() As Byte
Dim i As Integer
Dim sIPAddr As String
Dim werr As Long
If Not SocketsInitialize() Then
GetIPAddress = ""
Exit Function
End If
If TxtCmpName = "" Then
If gethostname(sHostName, 256) = SOCKET_ERROR Then
werr = WSAGetLastError()
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
sHostName = Trim$(sHostName)
Else
sHostName = Trim$(TxtCmpName) & Chr$(0)
End If
' 获得指向主机信息结构的指针
lpHost = gethostbyname(sHostName)
' 如果指针为零,则错误退出
If lpHost = 0 Then
werr = WSAGetLastError()
GetIPAddress = ""
SocketsCleanup
Exit Function
End If
' 从指定内存取得数据
CopyMemory HOST, lpHost, Len(HOST)
CopyMemory dwIPAddr, HOST.hAddrList, 4
' 重新动态分配变量内存
ReDim tmpIPAddr(1 To HOST.hLen)
' 将主机地址存储到tmpIPAddr中
CopyMemory tmpIPAddr(1), dwIPAddr, HOST.hLen
' 获得最终的主机IP地址字符串
For i = 1 To HOST.hLen
sIPAddr = sIPAddr & tmpIPAddr(i) & "."
Next
' 返回
GetIPAddress = Mid$(sIPAddr, 1, Len(sIPAddr) - 1)
If WSACleanup() <> ERROR_SUCCESS Then
App.LogEvent "Socket error occurred in Cleanup.", vbLogEventTypeError
End If
Screen.MousePointer = vbDefault
End Function