Lấy thông tin của Network

[levanduyet]

Chào các bạn,
Trong một số trường hợp lập trình VBA trong Excel bạn lại cần biết đến các thông tin của Network. Tôi xin giới thiệu với các bạn file tôi tìm trên trang web
http://www.appspro.com/
Đầu tiên bạn đưa đoạn code này vào module

Option Explicit

''' **************************************************************************
''' Module constant declarations follow.
''' **************************************************************************
''' API constants.
Private Const NERR_SUCCESS As Long = 0&
Private Const GET_USER_INFO_1 As Long = 1&
Private Const VER_PLATFORM_WIN32_NT As Long = 2&
Private Const MAX_PREFERRED_LENGTH As Long = &H4000&    ''' Tells the NetUserGetLocalGroups API to allocate as much memory as required for the return result.


''' **************************************************************************
''' Module type declarations follow.
''' **************************************************************************
''' This struct is loaded by the GetVersionExA API.
Private Type OSVERSIONINFO
    dwOSVersionInfoSize As Long
    dwMajorVersion As Long
    dwMinorVersion As Long
    dwBuildNumber As Long
    dwPlatformId As Long
    szCSDVersion As String * 128
End Type

''' This is the struct returned by the NetWkstaUserGetInfo API.
Private Type WKSTA_USER_INFO_1
    wkui1_username As Long
    wkui1_logon_domain As Long
    wkui1_oth_domains As Long
    wkui1_logon_server As Long
End Type

''' This is a VB-friendly version of the WKSTA_USER_INFO_1 that we'll load.
Private Type VB_WKSTA_USER_INFO_1
    UserName As String
    LogonDomain As String
    OtherDomains As String
    LogonServer As String
End Type


''' **************************************************************************
''' Module DLL declarations follow.
''' **************************************************************************
Private Declare Function GetVersionExA Lib "kernel32" (ByRef lpVersionInformation As OSVERSIONINFO) As Long
Private Declare Function NetWkstaUserGetInfo Lib "netapi32" (ByVal reserved As Any, ByVal Level As Long, ByRef lpBuffer As Any) As Long
Private Declare Function NetUserGetGroups Lib "netapi32" (ByRef lpServer As Any, ByRef UserName As Byte, ByVal Level As Long, ByRef lpBuffer As Long, ByVal PrefMaxLen As Long, ByRef lpEntriesRead As Long, ByRef lpTotalEntries As Long) As Long
Private Declare Function NetApiBufferFree Lib "netapi32" (ByVal lpBuffer As Long) As Long
Private Declare Sub CopyMem Lib "kernel32" Alias "RtlMoveMemory" (ByRef pTo As Any, ByRef uFrom As Any, ByVal lSize As Long)
Private Declare Function lstrlenW Lib "kernel32" (ByVal lpString As Long) As Long


Public Sub ReturnUserInfo()

    Dim lIndex As Long
    Dim lOffset As Long
    Dim aszGroups() As String
    Dim uUserInfo As VB_WKSTA_USER_INFO_1
    
    Sheet1.Range("Clear").ClearContents

    If bGetUserInfo(uUserInfo) Then
        If bGetGlobalGroups(uUserInfo.UserName, uUserInfo.LogonServer, aszGroups()) Then
            Sheet1.Range("Username").Value = uUserInfo.UserName
            Sheet1.Range("Server").Value = uUserInfo.LogonServer
            Sheet1.Range("Domain").Value = uUserInfo.LogonDomain
            For lIndex = LBound(aszGroups) To UBound(aszGroups)
                Sheet1.Range("Groups").Offset(lOffset, 0).Value = aszGroups(lIndex)
                lOffset = lOffset + 1
            Next lIndex
        End If
    End If

End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments:   Get information about the currently logged on user.
'''
''' Arguments:  uUserInfo       [out] A variable of type VB_WKSTA_USER_INFO_1
'''                             that will be loaded by this procedure.
'''
''' Returns:    Boolean         True on success, False on Error.
'''
''' Date        Developer       Action
''' --------------------------------------------------------------------------
''' 05/15/05    Rob Bovey       Created
'''
Private Function bGetUserInfo(ByRef uUserInfo As VB_WKSTA_USER_INFO_1) As Boolean

    Dim lpBuffer As Long
    Dim lReturn As Long
    Dim uVerInfo As OSVERSIONINFO
    Dim uAPIUserInfo As WKSTA_USER_INFO_1
    
    On Error GoTo ErrorHandler
    
    ''' First make sure we're on Windows NT/2000.
    uVerInfo.dwOSVersionInfoSize = Len(uVerInfo)
    GetVersionExA uVerInfo
    If uVerInfo.dwPlatformId <> VER_PLATFORM_WIN32_NT Then Err.Raise 9999, , "This application can only be run on Windows NT/2000/2003."

    ''' Get the information about the logged on user.
    lReturn = NetWkstaUserGetInfo(0&, GET_USER_INFO_1, lpBuffer)
    
    If lReturn = NERR_SUCCESS Then
    
        If lpBuffer <> 0 Then
        
            ''' Retrieve the struct from the pointer returned by the API call.
            CopyMem uAPIUserInfo, ByVal lpBuffer, Len(uAPIUserInfo)
            
            ''' Transfer the data into our VB-friendly structure.
            uUserInfo.UserName = szPointerToStringW(uAPIUserInfo.wkui1_username)
            uUserInfo.LogonDomain = szPointerToStringW(uAPIUserInfo.wkui1_logon_domain)
            uUserInfo.OtherDomains = szPointerToStringW(uAPIUserInfo.wkui1_oth_domains)
            uUserInfo.LogonServer = szPointerToStringW(uAPIUserInfo.wkui1_logon_server)
            
            ''' Clean up.
            NetApiBufferFree lpBuffer
        
        End If
        
    End If

    bGetUserInfo = True
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description, vbCritical
    bGetUserInfo = False
End Function


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' Comments:   Returns the list of global groups on the specified server that
'''             the specified user belongs to.
'''
''' Arguments:  szUserName      [in] The username to return the group list for.
'''             szServer        [in] The server where the global groups are
'''                             defined.
'''             aszGroups()     [out] An array of global group names that the
'''                             specified user belongs to.
'''
''' Returns:    Boolean         True on success, False on Error.
'''
''' Date        Developer       Action
''' --------------------------------------------------------------------------
''' 05/15/05    Rob Bovey       Created
'''
Private Function bGetGlobalGroups(ByRef szUserName As String, ByRef szServer As String, ByRef aszGroups() As String) As Boolean

    Dim abytUserName() As Byte
    Dim abytServer() As Byte
    Dim lpBuffer As Long
    Dim lNumRead As Long
    Dim lTotal As Long
    Dim lReturn As Long
    Dim lIndex As Long
    Dim alGroups() As Long
    
    On Error GoTo ErrorHandler
    
    abytUserName = szUserName & vbNullChar
    
    If InStr(szServer, "\\") = 1 Then
        abytServer = szServer & vbNullChar
    Else
        abytServer = "\\" & szServer & vbNullChar
    End If
    
    lReturn = NetUserGetGroups(abytServer(0), abytUserName(0), 0&, lpBuffer, MAX_PREFERRED_LENGTH, lNumRead, lTotal)
    
    If lReturn = NERR_SUCCESS Then
    
        If lpBuffer <> 0 Then
        
            ReDim alGroups(0 To lNumRead - 1)
            ReDim aszGroups(0 To lNumRead - 1)
            
            ''' Load the list of pointers to the group names returned by the API call.
            CopyMem alGroups(0), ByVal lpBuffer, lNumRead * 4   ''' lNumRead * sizeof(long*)
            
            ''' Convert the pointers to VB strings.
            For lIndex = 0 To lNumRead - 1
                aszGroups(lIndex) = szPointerToStringW(alGroups(lIndex))
            Next lIndex
            
            ''' We must free the memory buffer that was allocated by the call to NetUserGetLocalGroups.
            NetApiBufferFree lpBuffer
            
        End If
        
    End If
    
    bGetGlobalGroups = True
    Exit Function
    
ErrorHandler:
    MsgBox Err.Description, vbCritical
    bGetGlobalGroups = False
End Function


''' Returns a VB string from a pointer to a Unicode string.
Private Function szPointerToStringW(ByRef lpStringW As Long) As String

    Dim bytBuffer() As Byte
    Dim lNumBytes As Long
    
    If lpStringW <> 0 Then
    
        ''' The lstrlenW API returns the number of Unicode characters located at lpStringW.
        ''' We multiply by 2 because we need the number of bytes.
        lNumBytes = lstrlenW(lpStringW) * 2
        
        If lNumBytes > 0 Then
            ''' Allocate enough memory to hold the string.
            ReDim bytBuffer(0 To (lNumBytes - 1)) As Byte
            ''' Beginning at the memory location specified by lpStringW,
            ''' copy the specified number of bytes into our buffer.
            CopyMem bytBuffer(0), ByVal lpStringW, lNumBytes
            ''' VB automatically performs a Byte array to String conversion.
            szPointerToStringW = bytBuffer
        End If
    
    End If
   
End Function


''' Returns a Long value from the specified memory location.
Private Function lPointerToDWord(ByRef lpDWord As Long) As Long
   Dim lReturn As Long
   If lpDWord <> 0 Then
      CopyMem lReturn, ByVal lpDWord, 4
      lPointerToDWord = lReturn
   End If
End Function

 

[levanduyet]

Sau đó bạn viết một thủ tục để lấy thông tin dựa vào các hàm trên như sau:

Public Sub ReturnUserInfo()

    Dim lIndex As Long
    Dim lOffset As Long
    Dim aszGroups() As String
    Dim uUserInfo As VB_WKSTA_USER_INFO_1
    
    Sheet1.Range("Clear").ClearContents

    If bGetUserInfo(uUserInfo) Then
        If bGetGlobalGroups(uUserInfo.UserName, uUserInfo.LogonServer, aszGroups()) Then
            'Chú ý rằng bạn đã đặt tên 3 vùng trên Sheet1 là
            ' Username, Server, Domain
            Sheet1.Range("Username").Value = uUserInfo.UserName
            Sheet1.Range("Server").Value = uUserInfo.LogonServer
            Sheet1.Range("Domain").Value = uUserInfo.LogonDomain
            For lIndex = LBound(aszGroups) To UBound(aszGroups)
                Sheet1.Range("Groups").Offset(lOffset, 0).Value = aszGroups(lIndex)
                lOffset = lOffset + 1
            Next lIndex
        End If
    End If

End Sub

Hy vọng nó sẽ giúp ích cho các bạn,

Lê Văn Duyệt

 

[levanduyet]

Làm thế nào để lấy một địa chỉ IP?

Các bạn hãy copy đoạn code sau đưa vào một module, và thực thi thủ tục DemoGetIPAddress. Bạn sẽ thấy kết quả.

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


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 & vbLf & aszIPAddresses(lIndex)
        Next lIndex
        MsgBox szSuccessMsg, vbInformation, "Get IP Address Demo"
    Else
        MsgBox gszErrMsg, vbCritical, "Get IP Address Demo"
    End If
    
End Sub


''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''' 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