Option Explicit
Private Declare Function GetComputerName Lib "kernel32" _
Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Public Declare Function GetUserName Lib "advapi32.dll" _
Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long
Function ReturnComputerName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetComputerName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnComputerName = UCase(Trim(tString))
End Function
Function ReturnUserName() As String
Dim rString As String * 255, sLen As Long, tString As String
tString = ""
On Error Resume Next
sLen = GetUserName(rString, 255)
sLen = InStr(1, rString, Chr(0))
If sLen > 0 Then
tString = Left(rString, sLen - 1)
Else
tString = rString
End If
On Error GoTo 0
ReturnUserName = UCase(Trim(tString))
End Function
Sub Testem()
Dim iComNm As String
Dim iUsrNm As String
Dim rDate As Date
rDate = Now()
iComNm = ReturnComputerName
iUsrNm = ReturnUserName
MsgBox "You are logged in as the following..." & vbNewLine & _
"Computer : " & iComNm & vbNewLine & _
"Username : " & iUsrNm & vbNewLine & _
"IP Address : ???" & vbNewLine & _
"Date : " & rDate
Sheets("UserLog").Range("A65536").End(xlUp).Offset(1).Value = iComNm
Sheets("UserLog").Range("C65536").End(xlUp).Offset(1).Value = iUsrNm
Sheets("UserLog").Range("D65536").End(xlUp).Offset(1).Value = rDate
End Sub
Sub GetComInfo()
Dim p1 As String, p2 As String
On Error Resume Next
p1 = "HKLM\SYSTEM\ControlSet001\Control\ComputerName\ComputerName\ComputerName"
p2 = "HKLM\SOFTWARE\Microsoft\Windows NT\CurrentVersion\Winlogon\DefaultUserName"
With CreateObject("WScript.Shell")
MsgBox .RegRead(p1)
MsgBox .RegRead(p2)
End With
End Sub
Vâng! Tôi cũng rất thích API, và đang học nó... Nhưng cũng tùy việc mà xài...
Sub Test()
Dim Item
On Error Resume Next
With GetObject("winmgmts:\\.\root\cimv2")
For Each Item In .ExecQuery("Select * from Win32_NetworkAdapterConfiguration", , 48)
Range("A65536").End(xlUp).Offset(1) = Item.IPAddress(0)
Next
End With
End SubMsgBox Winsock1.LocalIPCái vụ IP này nói chung khá rắc rối (không dể như UserName và ComputerName) ---> Vì vậy bạn tạm thời chơi kiểu củ chuối như sau:
Public Function IPAddress() As String
'******************************************************************************
'* *
'* Name: IPAddress *
'* *
'* Purpose: Get IPAddress *
'* *
'* Returns: IPAddress *
'* *
'******************************************************************************
On Error GoTo PROC_ERROR
Dim ret As Long, i As Long
Dim bBytes() As Byte
Dim Listing As MIB_IPADDRTABLE
Dim strIP As String, strTemp As String
GetIpAddrTable ByVal 0&, ret, True
If ret <= 0 Then Exit Function
ReDim bBytes(0 To ret - 1) As Byte
'retrieve the data
GetIpAddrTable bBytes(0), ret, False
'Get the first 4 bytes to get the entry's.. ip installed
CopyMemory Listing.dEntrys, bBytes(0), 4
For i = 0 To Listing.dEntrys - 1
CopyMemory Listing.mIPInfo(i), bBytes(4 + (i * Len(Listing.mIPInfo(i)))), Len(Listing.mIPInfo(i))
strTemp = ConvertAddressToString(Listing.mIPInfo(i).dwAddr)
If strTemp <> "0.0.0.0" Then strIP = strIP & IIf(Len(strIP) = 0, "", ";") & strTemp
'//strIPSubNetMask = "IP Subnetmask : " & ConvertAddressToString(Listing.mIPInfo(i).dwMask)
'//strBroadCastIPAddress = "BroadCast IP address : " & ConvertAddressToString(Listing.mIPInfo(i).dwBCastAddr)
Next
IPAddress = strIP
PROC_DONE:
Exit Function
PROC_ERROR:
Call Process_Error(MODULE_NAME, "IPAddress")
Resume PROC_DONE
End FunctionVâng! Đương nhiên tôi tin vào kinh nghiệm của bạn rồi... Nhưng ác cái tôi chỉ mới tập tành VBA... VB thì mới "rờ rờ" sơ qua... API lại càng tịt... nên hàm mà bạn vừa đưa ra ở trên tôi không biết áp dụng vào Excel như thế nào nữa
Option Explicit
Const MAX_IP = 5
Type IPINFO
dwAddr As Long ' Get IP address
dwIndex As Long
dwMask As Long ' subnet mask
dwBCastAddr As Long ' broadcast address
dwReasmSize As Long ' assembly size
unused1 As Integer
unused2 As Integer
End Type
Type MIB_IPADDRTABLE
dEntrys As Long 'number of entries in the table
mIPInfo(MAX_IP) As IPINFO 'array of IP address entries
End Type
Type IP_Array
mBuffer As MIB_IPADDRTABLE
BufferLen As Long
End Type
Private Declare Sub CopyMemory Lib "kernel32.dll" Alias "RtlMoveMemory" (ByRef Destination As Any, ByRef Source As Any, ByVal Length As Long)
'Private Declare Function GetIpAddrTable Lib "IPHLPAPI.dll" (ByRef pIpAddrTable As MIB_IPADDRTABLE, ByRef pdwSize As Long, ByVal border As Long) As Long
Private Declare Function GetIpAddrTable Lib "IPHLPAPI.dll" (ByRef pIpAddrTable As Byte, ByRef pdwSize As Long, ByVal border As Long) As Long
Public Function IPAddress() As Variant
'******************************************************************************
'* *
'* Name: IPAddress *
'* *
'* Purpose: Get IPAddress *
'* *
'* Returns: IPAddress *
'* *
'******************************************************************************
On Error GoTo PROC_ERROR
Dim ret As Long, i As Long
Dim bBytes() As Byte
Dim Listing As MIB_IPADDRTABLE
Dim strIP As String, strTemp As String
Dim TempArr() As String
Dim IPCount As Long
GetIpAddrTable ByVal 0&, ret, True
If ret <= 0 Then Exit Function
ReDim bBytes(0 To ret - 1) As Byte
'retrieve the data
GetIpAddrTable bBytes(0), ret, False
'Get the first 4 bytes to get the entry's.. ip installed
CopyMemory Listing.dEntrys, bBytes(0), 4
For i = 0 To Listing.dEntrys - 1
CopyMemory Listing.mIPInfo(i), bBytes(4 + (i * Len(Listing.mIPInfo(i)))), Len(Listing.mIPInfo(i))
strTemp = ConvertAddressToString(Listing.mIPInfo(i).dwAddr)
If strTemp <> "0.0.0.0" Then
IPCount = IPCount + 1
'strIP = strIP & IIf(Len(strIP) = 0, "", ";") & strTemp
ReDim Preserve TempArr(IPCount - 1) As String
TempArr(IPCount - 1) = strTemp
End If
'//strIPSubNetMask = "IP Subnetmask : " & ConvertAddressToString(Listing.mIPInfo(i).dwMask)
'//strBroadCastIPAddress = "BroadCast IP address : " & ConvertAddressToString(Listing.mIPInfo(i).dwBCastAddr)
Next
'IPAddress = strIP
[COLOR="Red"] 'Return to array of IP
'On the Excel Worksheet, select cells in the same row, enter formula =IPAddress() , to get the array values, press CTRL+SHIFT+ENTER (combination).
'If you want to get the first IP, enter formula =IPAddress() then pressing ENTER key only.[/COLOR]
IPAddress = TempArr
PROC_DONE:
Exit Function
PROC_ERROR:
'Call Process_Error(MODULE_NAME, "IPAddress")
Resume PROC_DONE
End Function
Public Function ConvertAddressToString(longAddr As Long) As String
Dim myByte(3) As Byte
Dim Cnt As Long
CopyMemory myByte(0), longAddr, 4
For Cnt = 0 To 3
ConvertAddressToString = ConvertAddressToString + CStr(myByte(Cnt)) & "."
Next Cnt
ConvertAddressToString = Left$(ConvertAddressToString, Len(ConvertAddressToString) - 1)
End FunctionSub Testem()
Dim iComNm As String
Dim iUsrNm As String
Dim iDate As Date
iDate = Now()
iComNm = ReturnComputerName
iUsrNm = ReturnUserName
MsgBox "You are logged in as the following..." & vbNewLine & _
"Computer : " & iComNm & vbNewLine & _
"Username : " & iUsrNm & vbNewLine & _
"---" & vbNewLine & _
"IP Address : ???.???.?.???" & vbNewLine & _
"---" & vbNewLine & _
"Date : " & iDate
Sheets("UserLog").Range("A65536").End(xlUp).Offset(1).Value = iComNm
Sheets("UserLog").Range("B65536").End(xlUp).Offset(1).Value = "???.???.?.???"
Sheets("UserLog").Range("C65536").End(xlUp).Offset(1).Value = iUsrNm
Sheets("UserLog").Range("D65536").End(xlUp).Offset(1).Value = iDate
End SubEm đã lấy được rồi, xin chia sẻ cùng các anh chị ở file đính kèm
