Lấy địa chỉ IP (1 người xem)

[levanduyet]

Chào các bạn,
Đôi khi bạn muốn biết địa chỉ IP của mình là gì các bạn có thể dùng đoạn code sau:

Option Explicit

''' *************************************************************************
''' Module Constant Declaractions Follow
''' *************************************************************************
Private Const WSADescription_Len As Long = 256
Private Const WSASYS_Status_Len As Long = 128
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 MIN_SOCKETS_REQD As Long = 1


''' *************************************************************************
''' Module Type Declaractions Follow
''' *************************************************************************
''' An intermediate type structure required by various API calls to obtain the IP address.
Private Type HOSTENT
    hName As Long
    hAliases As Long
    hAddrType As Integer
    hLength As Integer
    hAddrList As Long
End Type

''' This type structure is required by the WSAStartup API.
Private Type WSADATA
    wVersion As Integer ''' Low byte contains major version, High byte contains minor version.
    wHighVersion As Integer
    bytDescription(0 To WSADescription_Len) As Byte
    bytSystemStatus(0 To WSASYS_Status_Len) As Byte
    iMaxSockets As Integer
    iMaxUdpDg As Integer
    lpszVendorInfo As Long
End Type


''' *************************************************************************
''' Module Variable Declarations Follow
''' *************************************************************************
''' It's critical for the Get IP Address procedure to trap for errors, but I
''' didn't want that to distract from the example, so I'm employing a very
''' rudimentary error handling scheme here. This variable is used to pass error
''' messages between procedures.
Public gszErrMsg As String


''' *************************************************************************
''' Module DLL Declarations Follow
''' *************************************************************************
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal Hostname As String) As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, ByRef lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Sub RtlMoveMemoryAny Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Sub RtlMoveMemoryLong Lib "kernel32" Alias "RtlMoveMemory" (ByRef hpvDest As Long, ByVal hpvSource As Long, ByVal cbCopy As Long)
Private Declare Function GetComputerNameA Lib "kernel32" (ByVal lpBuffer As String, ByRef nSize As Long) As Long





''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments:   Returns the IP address(es) assigned to the current computer.
'''
''' Arguments:  aszIPArray()    [out] An uninitialized string array that will
'''                             be loaded with all of the IP addresses assigned
'''                             to the computer this procedure is run on.
'''
'''                             NOTE: A computer can be assigned multiple IP
'''                             addresses. If you are sure the target computer
'''                             has only one IP address, simply use the first
'''                             element in this array.
'''
''' Returns:    Boolean         True on success, False on error.
'''
''' Date        Developer       Action
''' --------------------------------------------------------------------------
''' 05/20/05    Rob Bovey       Created
'''
Public Function bGetIPAddresses(ByRef aszIPArray() As String) As Boolean
    
    Dim bytTempBuffer() As Byte
    Dim uHost As HOSTENT
    Dim lStructPointer As Long
    Dim lIPPointer As Long
    Dim lNumIPs As Long
    Dim lAddress As Long
    Dim lOffset As Long
    Dim lNumBytes As Long
    Dim szHostName As String
    
    On Error GoTo ErrorHandler
    
    If Not bSocketsInitialize() Then Err.Raise 9999
    
    ''' Get the current computer name.
    szHostName = szGetComputerName()
    
    ''' Get the memory location of the HOSTENT type structure.
    lStructPointer = 0
    lStructPointer = gethostbyname(szHostName)
    If lStructPointer = 0 Then Err.Raise 9999, , "Winsock error: " & CStr(WSAGetLastError())
    
    ''' Load the HOSTENT type structure variable.
    RtlMoveMemoryAny uHost, lStructPointer, LenB(uHost)
    
    ''' Get the memory location of the IP address.
    RtlMoveMemoryLong lIPPointer, uHost.hAddrList, 4
    
    ''' Get the length of the IP Address list.
    ''' This works experimentally, I'm not sure if this is by accident or by design.
    lNumBytes = uHost.hName - lIPPointer    ''' It appears like uHost.hName begins at the memory address right after the last IP list address.
    lNumIPs = lNumBytes / 4                 ''' Each IP address is 4 bytes long
    ReDim bytTempBuffer(1 To lNumBytes)
    ReDim aszIPArray(1 To lNumIPs)
    
    ''' Load the IP address into our byte buffer.
    RtlMoveMemoryAny bytTempBuffer(1), lIPPointer, lNumBytes
    
    lOffset = 0
    For lAddress = 1 To lNumIPs
        ''' Each item in the byte array will be one of the octets in the IP address.
        aszIPArray(lAddress) = bytTempBuffer(1 + lOffset) & "." & bytTempBuffer(2 + lOffset) & "." & bytTempBuffer(3 + lOffset) & "." & bytTempBuffer(4 + lOffset)
        lOffset = lOffset + 4
    Next lAddress
    
    ''' Clean up the Winsock session.
    WSACleanup
    
    bGetIPAddresses = True
    Exit Function

ErrorHandler:
    If Len(gszErrMsg) = 0 Then gszErrMsg = Err.Description
    If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (bGetIPAddresses)"
    bGetIPAddresses = False
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments:   Initializes the Winsock session. This function must be called
'''             before any other Winsock APIs are used.
'''
''' Returns:    Boolean     True on success, False on error.
'''
''' Date        Developer           Action
''' --------------------------------------------------------------------------
''' 05/20/05    Rob Bovey           Created
'''
Private Function bSocketsInitialize() As Boolean

    Dim iVersion As Integer
    Dim lReturn As Long
    Dim uWinsockDetail As WSADATA
    
    On Error GoTo ErrorHandler
    
    ''' Call the Winsock startup API.
    lReturn = WSAStartup(WS_VERSION_REQD, uWinsockDetail)
    If lReturn <> 0 Then Err.Raise 9999, , "WSAStartup error: " & CStr(lReturn)
    
    iVersion = uWinsockDetail.wVersion
    
    If LowByte(iVersion) < WS_VERSION_MAJOR Or (LowByte(iVersion) = WS_VERSION_MAJOR And HighByte(iVersion) < WS_VERSION_MINOR) Then
        Err.Raise 9999, , "Required sockets version not supported by existing winsock.dll."
    ElseIf uWinsockDetail.iMaxSockets < MIN_SOCKETS_REQD Then
        Err.Raise 9999, , "Required sockets version not supported by existing winsock.dll."
    End If

    bSocketsInitialize = True
    Exit Function

ErrorHandler:
    If Len(gszErrMsg) = 0 Then gszErrMsg = Err.Description
    If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (bSocketsInitialize)"
    ''' Clean up the Winsock session.
    WSACleanup
    bSocketsInitialize = False
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments:   Returns the NETBIOS name of the current computer.
'''
''' Returns:    String      The name of the computer, or an empty string on
'''                         error.
'''
''' Date        Developer           Action
''' --------------------------------------------------------------------------
''' 05/20/05    Rob Bovey           Created
'''
Public Function szGetComputerName() As String

    Dim lReturn As Long
    Dim lLength As Long
    Dim szNameBuffer As String

    On Error GoTo ErrorHandler
    
    ''' Initialize variables.
    lLength = 255
    szNameBuffer = String$(lLength, vbNullChar)
    
    ''' Call the API function.
    lReturn = GetComputerNameA(szNameBuffer, lLength)
    If lReturn = 0 Then Err.Raise 9999
    
    ''' Strip out and return the computer name.
    szGetComputerName = Left$(szNameBuffer, lLength)
    Exit Function

ErrorHandler:
    gszErrMsg = Err.Description
    If Err.Number <> 9999 Then gszErrMsg = gszErrMsg & " (szGetComputerName)"
    szGetComputerName = vbNullString
End Function


''' Retrieve the high byte from the specifed integer argument.
Private Function HighByte(ByVal iNum As Integer) As Integer
    HighByte = iNum \ &H100 And &HFF
End Function


''' Retrieve the low byte from the specifed integer argument.
Private Function LowByte(ByVal iNum As Integer) As Integer
    LowByte = iNum And &HFF
End Function

Sau đó bạn dùng thủ tục sau để báo cho người dùng biết địa chỉ IP

Public Sub DemoGetIPAddress()

    Dim lIndex As Long
    Dim szSuccessMsg As String
    Dim aszIPAddresses() As String
    
    If bGetIPAddresses(aszIPAddresses) Then
        szSuccessMsg = "The IP address(es) assigned to this computer are:" & vbLf
        For lIndex = LBound(aszIPAddresses) To UBound(aszIPAddresses)
            szSuccessMsg = szSuccessMsg & aszIPAddresses(lIndex)
        Next lIndex
        MsgBox szSuccessMsg, vbInformation, "Get IP Address Demo"
    Else
        MsgBox gszErrMsg, vbCritical, "Get IP Address Demo"
    End If
    
End Sub

Lê Văn Duyệt