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
