获取电脑名及IP

Public Const WSADESCRIPTION_LEN = 256
Public Const WSASYS_STATUS_LEN = 128

Public Type HOSTENT
h_name As Long
h_aliases As Long
h_addrtype As Integer
h_length As Integer
h_addr_list As Long
End Type

Public Type WSADATA
wVersion As Long
wHighVersion As Long
szDescription(0 To WSADESCRIPTION_LEN) As Byte
szSystemStatus(0 To WSASYS_STATUS_LEN) As Byte
iMaxSockets As Long
iMaxUdpDg As Long
lpVendorInfo As Long
End Type

Public Declare Function WSAStartup Lib "WSOCK32.DLL" _
(ByVal wVersionRequested As Long, _
lpWSAData As WSADATA) As Long

Public Declare Function WSACleanup Lib "WSOCK32.DLL" _
() As Integer

Public Declare Function WSAIsBlocking Lib "WSOCK32.DLL" _
() As Boolean

Public Declare Function WSACancelBlockingCall Lib "WSOCK32.DLL" _
() As Integer

Public Declare Function GetHostName Lib "WSOCK32.DLL" _
Alias "gethostname" (ByVal name As _
String, ByVal namelen As Integer) As Integer

Public Declare Function gethostbyname Lib "WSOCK32.DLL" _
(ByVal name As String) As Long

Public Const wVersionRequired = &H101
Public Const wMajorVersion = wVersionRequired \ &H100 And &HFF&
Public Const wMinorVersion = wVersionRequired And &HFF&

Public Const ERROR_SUCCESS = 0

Declare Sub MoveMemory Lib "kernel32" _
Alias "RtlMoveMemory" _
(pDest As Any, _
ByVal pSource As Any, _
ByVal dwLength As Long)
Dim LoByte As Byte
Dim HiByte As Byte

Dim WSData As WSADATA

Public Sub SocketClose()
Dim iReturn As Integer

If WSAIsBlocking Then
WSACancelBlockingCall
End If

iReturn = WSACleanup()

If iReturn <> ERROR_SUCCESS Then
MsgBox "Windows Sockets " & CStr(LoByte) & "." & _
CStr(HiByte) & " can not be closed"
End If
End Sub

Public Function SocketStartup() As Integer
Dim iReturn As Integer

iReturn = WSAStartup(wVersionRequired, WSData)

If iReturn <> ERROR_SUCCESS Then
MsgBox "Windows Socket can not be started.", vbCritical + vbOKOnly

SocketStartup = iReturn

Exit Function
End If

HiByte = (WSData.wVersion And &HFF00&) \ (&H100)

LoByte = WSData.wVersion And &HFF&

If LoByte < wMajorVersion Or _
(LoByte = wMajorVersion And _
HiByte < wMinorVersion) Then

MsgBox "Sockets version " & CStr(LoByte) & "." & CStr(HiByte) _
& " is not supported.", vbCritical + vbOKOnly

SocketStartup = -1

Exit Function
End If

SocketStartup = iReturn
End Function

Public Function ResolveHostName() As String
Dim HostName As String
Dim dwLength As Integer

dwLength = 256

' 建立HostName字符串buffer
HostName = String(dwLength, Chr(0))

' 传回本地主机的名称(host name)
GetHostName HostName, Len(HostName)

ResolveHostName = Left(HostName, (Len(HostName) - 1))
End Function

Public Function ResolveIP() As String
Dim HostName As String
Dim dwLength As Integer
Dim RemoteHost As Long
Dim lHostEnt As HOSTENT
Dim InAddress As Long
Dim IPv4(0 To 3) As Byte

dwLength = 256

' 建立HostName字符串buffer
HostName = String(dwLength, Chr(0))

' 传回本地主机的名称(host name)
GetHostName HostName, Len(HostName)

RemoteHost = gethostbyname(Trim(HostName))

If RemoteHost = 0 Then
ResolveIP = "127.0.0.1"
Exit Function
Else
MoveMemory lHostEnt, RemoteHost, LenB(lHostEnt)

If lHostEnt.h_addr_list <> 0 Then
MoveMemory InAddress, lHostEnt.h_addr_list, lHostEnt.h_length

i = 0

Do While InAddress <> 0
MoveMemory IPv4(i), InAddress, lHostEnt.h_length

lHostEnt.h_addr_list = lHostEnt.h_addr_list + _
lHostEnt.h_length

MoveMemory InAddress, lHostEnt.h_addr_list, _
lHostEnt.h_length

i = i + 1
Loop

' 传回IPV4类型的主机IP address
ResolveIP = IPv4(0) & "." & IPv4(1) & "." & IPv4(2) & "." & IPv4(3)
Else
ResolveIP = "127.0.0.1"
End If
End If
End Function
Public Function GetDNName()
Dim StartupStatus As Integer

StartupStatus = SocketStartup()

If (StartupStatus <> ERROR_SUCCESS) Then
MsgBox "Windows Sockets " & CStr(LoByte) & "." & CStr(HiByte) & " is not available."
Else

GetDNName = ResolveHostName

SocketClose
End If
End Function
Public Function GetDNIp()
Dim StartupStatus As Integer

StartupStatus = SocketStartup()

If (StartupStatus <> ERROR_SUCCESS) Then
MsgBox "Windows Sockets " & CStr(LoByte) & "." & CStr(HiByte) & " is not available."
Else
GetDNIp = ResolveIP

SocketClose
End If
End Function