frmgetmultiip.frm

来自「vb发送文件,检查邮件,串口操作,查看文件等关于socket的源代码!」· FRM 代码 · 共 287 行

VERSION 5.00
Object = "{248DD890-BB45-11CF-9ABC-0080C7E7B78D}#1.0#0"; "MSWINSCK.OCX"
Begin VB.Form FrmGetMultiIP 
   Caption         =   "获取机器的多个IP地址"
   ClientHeight    =   3255
   ClientLeft      =   2355
   ClientTop       =   3555
   ClientWidth     =   5880
   LinkTopic       =   "Form1"
   ScaleHeight     =   3255
   ScaleWidth      =   5880
   Begin MSWinsockLib.Winsock Winsock1 
      Left            =   4200
      Top             =   1755
      _ExtentX        =   741
      _ExtentY        =   741
      _Version        =   393216
   End
   Begin VB.CommandButton cmdGetIPAddrs 
      Caption         =   "&G 获取IP地址"
      Height          =   420
      Left            =   3900
      TabIndex        =   1
      Top             =   225
      Width           =   1665
   End
   Begin VB.TextBox Text1 
      Height          =   3030
      Left            =   75
      MultiLine       =   -1  'True
      ScrollBars      =   2  'Vertical
      TabIndex        =   0
      Top             =   90
      Width           =   3540
   End
End
Attribute VB_Name = "FrmGetMultiIP"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = False
Attribute VB_PredeclaredId = True
Attribute VB_Exposed = False

Private Const MIN_SOCKETS_REQD As Long = 1
Private Const WS_VERSION_REQD As Long = &H101
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 Const SOCKET_ERROR As Long = -1
Private Const WSADESCRIPTION_LEN = 257
Private Const WSASYS_STATUS_LEN = 129
Private Const MAX_WSADescription = 256
Private Const MAX_WSASYSStatus = 128

Private Const SOCK_STREAM = 1
Private Const AF_INET = 2

Private Const SIO_GET_INTERFACE_LIST = &H4004747F
Private Const IFF_UP = &H1
Private Const IFF_BROADCAST = &H2
Private Const IFF_LOOPBACK = &H4
Private Const IFF_POINTTOPOINT = &H8
Private Const IFF_MULTICAST = &H10

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 Type WSADataInfo
    wVersion As Integer
    wHighVersion As Integer
    szDescription As String * WSADESCRIPTION_LEN
    szSystemStatus As String * WSASYS_STATUS_LEN
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpVendorInfo As String
End Type
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLen As Integer
    hAddrList As Long
End Type
Private Type WSAOVERLAPPED
    Internal As Long
    InternalHigh As Long
    Offset As Long
    OffsetHigh As Long
    hEvent As Long          ' 可以为Null
End Type
Private Type sockaddr
    sin_family As Integer
    sin_port As Integer
    sin_addr As Long
    sin_zero As String * 8
End Type
Private Type sockaddr_gen
    AddressIn As sockaddr
    filler(0 To 7) As Byte
End Type
Private Type INTERFACE_INFO                 ' packed record
      iiFlags As Long                       ' Interface flags
      sin_family As Integer
      sin_port As Integer
      sin_addr(0 To 3) As Byte
      sin_zero As String * 8
      filler(0 To 7) As Byte
      iiBroadcastAddress As sockaddr_gen    ' Broadcast address
      iiNetmask As sockaddr_gen             ' Network mask
End Type
 
Private Declare Function WSAStartupInfo Lib "WSOCK32" Alias "WSAStartup" (ByVal wVersionRequested As Integer, lpWSADATA As WSADataInfo) As Long
Private Declare Function WSACleanup Lib "WSOCK32" () As Long
Private Declare Function WSAGetLastError Lib "WSOCK32" () As Long
Private Declare Function WSAStartup Lib "WSOCK32" (ByVal wVersionRequired As Long, lpWSADATA As WSAData) As Long
Private Declare Function socket Lib "wsock32.dll" (ByVal af As Long, ByVal s_type As Long, ByVal protocol As Long) As Long
Private Declare Function closesocket Lib "wsock32.dll" (ByVal s As Long) As Long
Private Declare Function WSAIoctl Lib "WS2_32" (ByVal s As Long, ByVal dwIoControlCode As Long, _
    lpvInBuffer As Any, ByVal cbInBuffer As Long, _
    lpvOUTBuffer As Any, ByVal cbOUTBuffer As Long, lpcbBytesReturned As Long, _
    lpOverlapped As Any, lpCompletionROUTINE As Long) As Long
    
Private Declare Function lstrlenA Lib "kernel32" (ByVal Ptr As Any) As Long

Private Declare Function gethostbyaddr Lib "wsock32.dll" (haddr As Long, ByVal hnlen As Long, ByVal addrtype As Long) As Long
Private Declare Function GetHostName Lib "WSOCK32" Alias "gethostname" (ByVal szHost As String, ByVal dwHostLen As Long) As Long
Private Declare Function gethostbyname Lib "WSOCK32" (ByVal szHost As String) As Long
Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Any, ByVal hpvSource As Any, ByVal cbCopy As Long)
Private Declare Sub CopyMemoryEx Lib "kernel32" Alias "RtlMoveMemory" (hpvDest As Long, hpvSource As Byte, ByVal cbCopy As Long)

Private Function GetIPAddress() As String
    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
    If Not SocketsInitialize() Then
        GetIPAddress = ""
        Exit Function
    End If
    If GetHostName(sHostName, 256) = SOCKET_ERROR Then
        GetIPAddress = ""
        MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If
    sHostName = Trim$(sHostName)
    lpHost = gethostbyname(sHostName)
    If lpHost = 0 Then
        GetIPAddress = ""
        MsgBox "Windows Sockets are not responding. " & "Unable to successfully get Host Name."
        SocketsCleanup
        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)
    SocketsCleanup
End Function
Private Function GetIPHostName() As String
    Dim sHostName As String * 256
    If Not SocketsInitialize() Then
        GetIPHostName = ""
        Exit Function
    End If
    If GetHostName(sHostName, 256) = SOCKET_ERROR Then
        GetIPHostName = ""
        MsgBox "Windows Sockets error " & Str$(WSAGetLastError()) & " has occurred. Unable to successfully get Host Name."
        SocketsCleanup
        Exit Function
    End If
    GetIPHostName = Left$(sHostName, InStr(sHostName, Chr(0)) - 1)
    SocketsCleanup
End Function
Public Function GetHostNameByAddr(ByVal Address As Long) As String
    Dim lLength As Long, lRet As Long
    lRet = gethostbyaddr(Address, 4, AF_INET)
    If lRet <> 0 Then
        CopyMemory lRet, ByVal lRet, 4
        lLength = lstrlenA(lRet)
        If lLength > 0 Then
            GetHostNameByAddr = Space$(lLength)
            CopyMemory ByVal GetHostNameByAddr, ByVal lRet, lLength
        End If
    Else
        GetHostNameByAddr = ""
    End If
End Function
Private Function HiByte(ByVal wParam As Integer)
    HiByte = wParam \ &H100 And &HFF&
End Function
Private Function LoByte(ByVal wParam As Integer)
    LoByte = wParam And &HFF&
End Function
Private Sub SocketsCleanup()
    If WSACleanup() <> ERROR_SUCCESS Then
        MsgBox "Socket error occurred in Cleanup."
    End If
End Sub
Private Function SocketsInitialize() As Boolean
    Dim WSAD As WSAData
    Dim sLoByte As String
    Dim sHiByte As String
    If WSAStartup(WS_VERSION_REQD, WSAD) <> ERROR_SUCCESS Then
        MsgBox "The 32-bit Windows Socket is not responding."
        SocketsInitialize = False
        Exit Function
    End If
    If WSAD.wMaxSockets < MIN_SOCKETS_REQD Then
        MsgBox "This application requires a minimum of " & CStr(MIN_SOCKETS_REQD) & " supported sockets."
        SocketsInitialize = False
        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
        sHiByte = CStr(HiByte(WSAD.wVersion))
        sLoByte = CStr(LoByte(WSAD.wVersion))
        MsgBox "Sockets version " & sLoByte & "." & sHiByte & " is not supported by 32-bit Windows Sockets."
        SocketsInitialize = False
        Exit Function
    End If
    'must be OK, so lets do it
    SocketsInitialize = True
End Function

Private Function EnumAllAdapter() As String
    Dim s As Long
    Dim HOST As HOSTENT
    Dim iInfo As INTERFACE_INFO, nb As Integer
    Dim buffer As INTERFACE_INFO
    Dim byts(0 To 4095) As Byte, vbnil As Long
    Dim BytesReturned As Long, NumInterfaces As Integer
    
    If Not SocketsInitialize() Then
        EnumAllAdapter = ""
        Exit Function
    End If
    
    s = socket(AF_INET, SOCK_STREAM, 0)
    If (s = INVALID_SOCKET) Then
        EnumAllAdapter = ""
        Exit Function
    End If
    
    vbnil = 0
    If WSAIoctl(s, SIO_GET_INTERFACE_LIST, vbnil, vbnil, byts(0), 1024, BytesReturned, 0, 0) <> SOCKET_ERROR Then
        nb = Len(iInfo)
        NumInterfaces = BytesReturned / nb
        EnumAllAdapter = ""
        For I = 0 To NumInterfaces - 1      ' 返回多个IP地址
            CopyMemoryEx buffer.iiFlags, byts(I * nb), nb
            With buffer
                CopyMemoryEx vbnil, .sin_addr(0), 4
                EnumAllAdapter = EnumAllAdapter _
                    & .sin_addr(0) & "." & .sin_addr(1) & "." _
                    & .sin_addr(2) & "." & .sin_addr(3) & "," _
                    & GetHostNameByAddr(vbnil) _
                    & vbCrLf
            End With
        Next
    Else
        EnumAllAdapter = ""
    End If
    
    Call closesocket(s)
    SocketsCleanup
End Function


Private Sub Form_Load()
    Me.Text1 = "常规方法：" & GetIPAddress() & vbCrLf
    Me.Text1 = Me.Text1 & vbCrLf & "获取所有IP地址：" & vbCrLf _
            & EnumAllAdapter()

End Sub