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

--------------------------------------------------------------------------------
相关文章
剖析 Declare 语句 2004-1-28 15:08:06
了解句柄 2004-1-28 15:03:43
什么是 API？ 2004-1-28 15:01:53
对注册表操作技巧-将程序在开机时运行 2003-11-18 9:24:59
officeXP下使用文件对话框的另外一种方法 2003-11-17 8:47:04
真正实现在windows2000下关机的源代码 2003-11-14 8:32:00
获取Windows用户登录名 2003-11-7 8:42:45
获取网卡物理地址 2003-11-7 8:40:48
隐藏Access主窗口之二 2003-11-7 8:34:20
如何让窗体总在最前面？ 2003-11-7 8:25:19
如何关闭计算机？ 2003-11-7 8:24:43
如何建立简单的超级连接？(ShellExecute) 2003-11-6 20:39:18
如何让窗体的标题条闪烁以引起用户注意？ 2003-11-6 20:38:43
怎样找到鼠标指针的XY坐标？ 2003-11-6 20:37:33
在程序中如何打开和关闭光驱门？ 2003-11-6 20:20:00
怎样使Ctrl-Alt-Delete无效？ 2003-11-6 20:19:25
如何移动没有标题栏的窗口？ 2003-11-6 20:17:30
延时函数 2003-11-6 20:16:53
让控件自适应屏幕分辨率 2003-10-18 9:58:33
键盘常用代码一览表 2003-10-17 19:54:02
重新定位链接表二步走 2003-10-17 19:00:07
ADO连接数据库字符串大全 2003-10-17 18:40:47
如何确定当前屏幕分辨率 2003-10-14 8:41:00
获取windows安装路径 2003-10-14 8:39:08
将 Microsoft Access 用作 Automation 服务器 2003-10-14 8:37:19
优化Microsoft Access提高速度 2003-10-6 10:31:55