已有23人关注
《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




分享到:
精彩评论 1
Lemon
学分:0 LV1
2009-07-10
沙发
您好,这里是修正后的代码。
首页上一页 1 下一页尾页 1 条记录 1/1页
手机同步功能介绍
友情提示:以下图书配套资源能够实现手机同步功能
明日微信公众号
明日之星 明日之星编程特训营
客服热线(每日9:00-17:00)
400 675 1066
mingrisoft@mingrisoft.com
吉林省明日科技有限公司Copyright ©2007-2022,mingrisoft.com, All Rights Reserved长春市北湖科技开发区盛北大街3333号长春北湖科技园项目一期A10号楼四、五层
吉ICP备10002740号-2吉公网安备22010202000132经营性网站备案信息 营业执照