Option ExplicitPublic Const MAX_ADAPTER_NAME_LENGTH As Long = 256 Public Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128 Public Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8 Public Const ERROR_SUCCESS As Long = 0Public Type IP_ADDRESS_STRING IpAddr(0 To 15) As Byte End TypePublic Type IP_MASK_STRING IpMask(0 To 15) As Byte End TypePublic Type IP_ADDR_STRING dwNext As Long IpAddress As IP_ADDRESS_STRING IpMask As IP_MASK_STRING dwContext As Long End TypePublic Type IP_ADAPTER_INFO dwNext As Long ComboIndex As Long '保留 sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte dwAddressLength As Long sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte dwIndex As Long uType As Long uDhcpEnabled As Long CurrentIpAddress As Long IpAddressList As IP_ADDR_STRING GatewayList As IP_ADDR_STRING DhcpServer As IP_ADDR_STRING bHaveWins As Long PrimaryWinsServer As IP_ADDR_STRING SecondaryWinsServer As IP_ADDR_STRING LeaseObtained As Long LeaseExpires As Long End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _ (pTcpTable As Any, _ pdwSize As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _ (dst As Any, _ src As Any, _ ByVal bcount As Long) Function LocalIPAddress() As String Dim cbRequired As Long Dim buff() As Byte Dim Adapter As IP_ADAPTER_INFO Dim AdapterStr As IP_ADDR_STRING Dim ptr1 As Long Dim sIPAddr As String Dim found As Boolean Call GetAdaptersInfo(ByVal 0&, cbRequired) If cbRequired > 0 Then ReDim buff(0 To cbRequired - 1) As Byte If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then '获取存放在buff()中的数据的指针 ptr1 = VarPtr(buff(0)) Do While (ptr1 <> 0) '将第一个网卡的数据转换到IP_ADAPTER_INFO结构中 CopyMemory Adapter, ByVal ptr1, LenB(Adapter) With Adapter 'IpAddress.IpAddr成员给出了DHCP的IP地址 sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode)) If Len(sIPAddr) > 0 Then found = True Exit Do End If ptr1 = .dwNext End With 'With Adapter '不再有网卡时,ptr1的值为0 Loop 'Do While (ptr1 <> 0) End If 'If GetAdaptersInfo End If 'If cbRequired > 0 '返回结果字符串 LocalIPAddress = sIPAddr End Function Function TrimNull(item As String) Dim pos As Integer pos = InStr(item, Chr$(0)) If pos Then TrimNull = Left$(item, pos - 1) Else: TrimNull = item End If End Function
上面是获得IP地址,下面是获得机器名的:Private Declare Function GetComputerName Lib "kernel32.dll" Alias _ "GetComputerNameA" (Byval lpBuffer As String, nSize As Long) As Long Private Sub Command1_Click () Dim RetVal As Long Dim Puffer As String * 256 Dim ComputerName As String
RetVal = GetComputerName(Puffer, Len(Puffer)) ' Bei vbNullChar "abtrennen" und anzeigen If RetVal <> 0 Then ComputerName = Left$(Puffer, Instr(1, Puffer, vbNullChar) - 1) MsgBox "Der Computername ist: " & ComputerName End If End Sub
Private Const WS_VERSION_REQD = &H101 Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF& Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF& Private Const MIN_SOCKETS_REQD = 1 Private Const SOCKET_ERROR = -1 Private Const WSADescription_Len = 256 Private Const WSASYS_Status_Len = 128Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End TypePrivate Type WSADATA wversion As Integer wHighVersion As Integer szDescription(0 To WSADescription_Len) As Byte szSystemStatus(0 To WSASYS_Status_Len) As Byte iMaxSockets As Integer iMaxUdpDg As Integer lpszVendorInfo As Long End TypePrivate Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)Function hibyte(ByVal wParam As Integer)
hibyte = wParam \ &H100 And &HFF&
End FunctionFunction lobyte(ByVal wParam As Integer)
lobyte = wParam And &HFF&
End FunctionSub SocketsInitialize()
Dim WSAD As WSADATA Dim iReturn As Integer Dim sLowByte As String, sHighByte As String, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then MsgBox "Winsock.dll is not responding." End End If
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then sHighByte = Trim$(Str$(hibyte(WSAD.wversion))) sLowByte = Trim$(Str$(lobyte(WSAD.wversion))) sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte sMsg = sMsg & " is not supported by winsock.dll " MsgBox sMsg End End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then sMsg = "This application requires a minimum of " sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets." MsgBox sMsg End End If
End SubSub SocketsCleanup() Dim lReturn As Long
lReturn = WSACleanup()
If lReturn <> 0 Then MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup " End End If
End SubSub Form_Load()
SocketsInitialize
End SubPrivate Sub Form_Unload(Cancel As Integer)
SocketsCleanup
End SubPrivate Sub Command1_click() Dim hostent_addr As Long Dim host As HOSTENT Dim hostip_addr As Long Dim temp_ip_address() As Byte Dim i As Integer Dim ip_address As String
hostent_addr = gethostbyname(Text1)
If hostent_addr = 0 Then MsgBox "Can't resolve name." Exit Sub End If
Public Const MAX_ADAPTER_DESCRIPTION_LENGTH As Long = 128
Public Const MAX_ADAPTER_ADDRESS_LENGTH As Long = 8
Public Const ERROR_SUCCESS As Long = 0Public Type IP_ADDRESS_STRING
IpAddr(0 To 15) As Byte
End TypePublic Type IP_MASK_STRING
IpMask(0 To 15) As Byte
End TypePublic Type IP_ADDR_STRING
dwNext As Long
IpAddress As IP_ADDRESS_STRING
IpMask As IP_MASK_STRING
dwContext As Long
End TypePublic Type IP_ADAPTER_INFO
dwNext As Long
ComboIndex As Long '保留
sAdapterName(0 To (MAX_ADAPTER_NAME_LENGTH + 3)) As Byte
sDescription(0 To (MAX_ADAPTER_DESCRIPTION_LENGTH + 3)) As Byte
dwAddressLength As Long
sIPAddress(0 To (MAX_ADAPTER_ADDRESS_LENGTH - 1)) As Byte
dwIndex As Long
uType As Long
uDhcpEnabled As Long
CurrentIpAddress As Long
IpAddressList As IP_ADDR_STRING
GatewayList As IP_ADDR_STRING
DhcpServer As IP_ADDR_STRING
bHaveWins As Long
PrimaryWinsServer As IP_ADDR_STRING
SecondaryWinsServer As IP_ADDR_STRING
LeaseObtained As Long
LeaseExpires As Long
End TypePublic Declare Function GetAdaptersInfo Lib "iphlpapi.dll" _
(pTcpTable As Any, _
pdwSize As Long) As Long
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" _
(dst As Any, _
src As Any, _
ByVal bcount As Long)
Function LocalIPAddress() As String
Dim cbRequired As Long
Dim buff() As Byte
Dim Adapter As IP_ADAPTER_INFO
Dim AdapterStr As IP_ADDR_STRING
Dim ptr1 As Long
Dim sIPAddr As String
Dim found As Boolean
Call GetAdaptersInfo(ByVal 0&, cbRequired)
If cbRequired > 0 Then
ReDim buff(0 To cbRequired - 1) As Byte
If GetAdaptersInfo(buff(0), cbRequired) = ERROR_SUCCESS Then
'获取存放在buff()中的数据的指针
ptr1 = VarPtr(buff(0))
Do While (ptr1 <> 0)
'将第一个网卡的数据转换到IP_ADAPTER_INFO结构中
CopyMemory Adapter, ByVal ptr1, LenB(Adapter)
With Adapter
'IpAddress.IpAddr成员给出了DHCP的IP地址
sIPAddr = TrimNull(StrConv(.IpAddressList.IpAddress.IpAddr, vbUnicode))
If Len(sIPAddr) > 0 Then
found = True
Exit Do
End If
ptr1 = .dwNext
End With 'With Adapter
'不再有网卡时,ptr1的值为0
Loop 'Do While (ptr1 <> 0)
End If 'If GetAdaptersInfo
End If 'If cbRequired > 0
'返回结果字符串
LocalIPAddress = sIPAddr
End Function Function TrimNull(item As String)
Dim pos As Integer
pos = InStr(item, Chr$(0))
If pos Then
TrimNull = Left$(item, pos - 1)
Else: TrimNull = item
End If
End Function
"GetComputerNameA" (Byval lpBuffer As String, nSize As Long) As Long Private Sub Command1_Click ()
Dim RetVal As Long
Dim Puffer As String * 256
Dim ComputerName As String
RetVal = GetComputerName(Puffer, Len(Puffer)) ' Bei vbNullChar "abtrennen" und anzeigen
If RetVal <> 0 Then
ComputerName = Left$(Puffer, Instr(1, Puffer, vbNullChar) - 1)
MsgBox "Der Computername ist: " & ComputerName
End If
End Sub
Private Const WS_VERSION_REQD = &H101
Private Const WS_VERSION_MAJOR = WS_VERSION_REQD \ &H100 And &HFF&
Private Const WS_VERSION_MINOR = WS_VERSION_REQD And &HFF&
Private Const MIN_SOCKETS_REQD = 1
Private Const SOCKET_ERROR = -1
Private Const WSADescription_Len = 256
Private Const WSASYS_Status_Len = 128Private Type HOSTENT
hName As Long
hAliases As Long
hAddrType As Integer
hLength As Integer
hAddrList As Long
End TypePrivate Type WSADATA
wversion As Integer
wHighVersion As Integer
szDescription(0 To WSADescription_Len) As Byte
szSystemStatus(0 To WSASYS_Status_Len) As Byte
iMaxSockets As Integer
iMaxUdpDg As Integer
lpszVendorInfo As Long
End TypePrivate Declare Function WSAGetLastError Lib "WSOCK32.DLL" () As Long
Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired&, lpWSAData As WSADATA) As Long
Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname$) As Long
Private Declare Sub RtlMoveMemory Lib "KERNEL32" (hpvDest As Any, ByVal hpvSource&, ByVal cbCopy&)Function hibyte(ByVal wParam As Integer)
hibyte = wParam \ &H100 And &HFF&
End FunctionFunction lobyte(ByVal wParam As Integer)
lobyte = wParam And &HFF&
End FunctionSub SocketsInitialize()
Dim WSAD As WSADATA
Dim iReturn As Integer
Dim sLowByte As String, sHighByte As String, sMsg As String
iReturn = WSAStartup(WS_VERSION_REQD, WSAD)
If iReturn <> 0 Then
MsgBox "Winsock.dll is not responding."
End
End If
If lobyte(WSAD.wversion) < WS_VERSION_MAJOR Or (lobyte(WSAD.wversion) = WS_VERSION_MAJOR And hibyte(WSAD.wversion) < WS_VERSION_MINOR) Then
sHighByte = Trim$(Str$(hibyte(WSAD.wversion)))
sLowByte = Trim$(Str$(lobyte(WSAD.wversion)))
sMsg = "Windows Sockets version " & sLowByte & "." & sHighByte
sMsg = sMsg & " is not supported by winsock.dll "
MsgBox sMsg
End
End If
If WSAD.iMaxSockets < MIN_SOCKETS_REQD Then
sMsg = "This application requires a minimum of "
sMsg = sMsg & Trim$(Str$(MIN_SOCKETS_REQD)) & " supported sockets."
MsgBox sMsg
End
End If
End SubSub SocketsCleanup()
Dim lReturn As Long
lReturn = WSACleanup()
If lReturn <> 0 Then
MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "
End
End If
End SubSub Form_Load()
SocketsInitialize
End SubPrivate Sub Form_Unload(Cancel As Integer)
SocketsCleanup
End SubPrivate Sub Command1_click()
Dim hostent_addr As Long
Dim host As HOSTENT
Dim hostip_addr As Long
Dim temp_ip_address() As Byte
Dim i As Integer
Dim ip_address As String
hostent_addr = gethostbyname(Text1)
If hostent_addr = 0 Then
MsgBox "Can't resolve name."
Exit Sub
End If
RtlMoveMemory host, hostent_addr, LenB(host)
RtlMoveMemory hostip_addr, host.hAddrList, 4
ReDim temp_ip_address(1 To host.hLength)
RtlMoveMemory temp_ip_address(1), hostip_addr, host.hLength
For i = 1 To host.hLength
ip_address = ip_address & temp_ip_address(i) & "."
Next
ip_address = Mid$(ip_address, 1, Len(ip_address) - 1)
MsgBox ip_address
End Sub
使用winscok控件
Private Sub Form_Load()
MsgBox Winsock1.LocalHostName
End Sub