1.把以下代码做成一个bas文件
Option
Explicit
![](/Images/OutliningIndicators/None.gif)
Public
Const
MAX_WSADescription
=
256
Public
Const
MAX_WSASYSStatus
=
128
Public
Const
ERROR_SUCCESS
As
Long
=
0
Public
Const
WS_VERSION_REQD
As
Long
=
&
H101
Public
Const
WS_VERSION_MAJOR
As
Long
=
WS_VERSION_REQD
\
&
H100
And
&
HFF
&
Public
Const
WS_VERSION_MINOR
As
Long
=
WS_VERSION_REQD
And
&
HFF
&
Public
Const
MIN_SOCKETS_REQD
As
Long
=
1
Public
Const
SOCKET_ERROR
As
Long
=
-
1
![](/Images/OutliningIndicators/None.gif)
Public
Type HOSTENT
hName
As
Long
hAliases
As
Long
hAddrType
As
Integer
hLen
As
Integer
hAddrList
As
Long
End
Type
![](/Images/OutliningIndicators/None.gif)
Public
Type WSADATA
wVersion
As
Integer
wHighVersion
As
Integer
szDescription(
0
To
MAX_WSADescription)
As
Byte
szSystemStatus(
0
To
MAX_WSASYSStatus)
As
Byte
wMaxSockets
As
Integer
wMaxUDPDG
As
Integer
dwVendorInfo
As
Long
End
Type
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Declare
Function
WSAGetLastError Lib
"
WSOCK32.DLL
"
()
As
Long
![](/Images/OutliningIndicators/None.gif)
Public
Declare
Function
WSAStartup Lib
"
WSOCK32.DLL
"
_
(ByVal wVersionRequired
As
Long
, lpWSADATA
As
WSADATA)
As
Long
Public
Declare
Function
WSACleanup Lib
"
WSOCK32.DLL
"
()
As
Long
![](/Images/OutliningIndicators/None.gif)
Public
Declare
Function
gethostname Lib
"
WSOCK32.DLL
"
_
(ByVal szHost
As
String
, ByVal dwHostLen
As
Long
)
As
Long
Public
Declare
Function
gethostbyname Lib
"
WSOCK32.DLL
"
_
(ByVal szHost
As
String
)
As
Long
Public
Declare
Sub
CopyMemory Lib
"
kernel32
"
Alias
"
RtlMoveMemory
"
_
(hpvDest
As
Any, ByVal hpvSource
As
Long
, ByVal cbCopy
As
Long
)
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Function
GetIPAddress()
As
String
![](/Images/OutliningIndicators/None.gif)
Dim
sHostName
As
String
*
256
Dim
lpHost
As
Long
Dim
HOST
As
HOSTENT
Dim
dwIPAddr
As
Long
Dim
tmpIPAddr()
As
Byte
Dim
i
As
Integer
Dim
sIPAddr
As
String
If
Not
SocketsInitialize()
Then
GetIPAddress
=
""
Exit
Function
End
If
'
gethostname returns the name of the local host into
'
the buffer specified by the name parameter. The host
'
name is returned as a null-terminated string. The
'
form of the host name is dependent on the Windows
'
Sockets provider - it can be a simple host name, or
'
it can be a fully qualified domain name. However, it
'
is guaranteed that the name returned will be successfully
'
parsed by gethostbyname and WSAAsyncGetHostByName.
'
In actual application, if no local host name has been
'
configured, gethostname must succeed and return a token
'
host name that gethostbyname or WSAAsyncGetHostByName
'
can resolve.
If
gethostname(sHostName,
256
)
=
SOCKET_ERROR
Then
GetIPAddress
=
""
MsgBox
"
Windows Sockets error
"
&
Str$(WSAGetLastError())
&
_
"
has occurred. Unable to successfully get Host Name.
"
SocketsCleanup
Exit
Function
End
If
'
gethostbyname returns a pointer to a HOSTENT structure
'
- a structure allocated by Windows Sockets. The HOSTENT
'
structure contains the results of a successful search
'
for the host specified in the name parameter.
'
The application must never attempt to modify this
'
structure or to free any of its components. Furthermore,
'
only one copy of this structure is allocated per thread,
'
so the application should copy any information it needs
'
before issuing any other Windows Sockets function calls.
'
gethostbyname function cannot resolve IP address strings
'
passed to it. Such a request is treated exactly as if an
'
unknown host name were passed. Use inet_addr to convert
'
an IP address string the string to an actual IP address,
'
then use another function, gethostbyaddr, to obtain the
'
contents of the HOSTENT structure.
sHostName
=
Trim
$(sHostName)
lpHost
=
gethostbyname(sHostName)
If
lpHost
=
0
Then
GetIPAddress
=
""
MsgBox
"
Windows Sockets are not responding.
"
&
_
"
Unable to successfully get Host Name.
"
SocketsCleanup
Exit
Function
End
If
'
to extract the returned IP address, we have to copy
'
the HOST structure and its members
CopyMemory HOST, lpHost,
Len
(HOST)
CopyMemory dwIPAddr, HOST.hAddrList,
4
'
create an array to hold the result
ReDim
tmpIPAddr(
1
To
HOST.hLen)
CopyMemory tmpIPAddr(
1
), dwIPAddr, HOST.hLen
'
and with the array, build the actual address,
'
appending a period between members
For
i
=
1
To
HOST.hLen
sIPAddr
=
sIPAddr
&
tmpIPAddr(i)
&
"
.
"
Next
'
the routine adds a period to the end of the
'
string, so remove it here
GetIPAddress
=
Mid
$(sIPAddr,
1
,
Len
(sIPAddr)
-
1
)
SocketsCleanup
End Function
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Function
GetIPHostName()
As
String
![](/Images/OutliningIndicators/None.gif)
Dim
sHostName
As
String
*
256
If
Not
SocketsInitialize()
Then
GetIPHostName
=
""
Exit
Function
End
If
If
gethostname(sHostName,
256
)
=
SOCKET_ERROR
Then
GetIPHostName
=
""
MsgBox
"
Windows Sockets error
"
&
Str$(WSAGetLastError())
&
_
"
has occurred. Unable to successfully get Host Name.
"
SocketsCleanup
Exit
Function
End
If
GetIPHostName
=
Left
$(sHostName,
InStr
(sHostName,
Chr
(
0
))
-
1
)
SocketsCleanup
![](/Images/OutliningIndicators/None.gif)
End Function
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Function
HiByte(ByVal wParam
As
Integer
)
As
Integer
'
modified Oct 11/99
'
The origional method as
'
HiByte = wParam \ &H100 And &HFF&
'
would generate Division by 0 errors on some
'
systems when compiled to Native Code exe (yet
'
work in the IDE or when compiled as pCode).
'
Although adding brackets should force the
'
correct evaluation to occur first, the problem
'
remained on some systems. The additional step below
'
assigning the initial evaluation result to a temp
'
variable should reslove the problem. If it doesn't,
'
then it looks like a pCode compile needs to be used
'
with this (and, for that matter, possibly all)
'
projects.
Dim
tmp
as
Integer
tmp
=
wParam
\
&
H100
HiByte
=
tmp
And
&
HFF
&
![](/Images/OutliningIndicators/None.gif)
End Function
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Function
LoByte(ByVal wParam
As
Integer
)
As
Integer
![](/Images/OutliningIndicators/None.gif)
LoByte
=
wParam
And
&
HFF
&
![](/Images/OutliningIndicators/None.gif)
End Function
![](/Images/OutliningIndicators/None.gif)
![](/Images/OutliningIndicators/None.gif)
Public
Sub
SocketsCleanup()
![](/Images/OutliningIndicators/None.gif)
If
WSACleanup()
<>
ERROR_SUCCESS
Then
MsgBox
"
Socket error occurred in Cleanup.
"
End
If
End Sub
![](/Images/OutliningIndicators/None.gif)
Public
Function
SocketsInitialize()
As
Boolean
![](/Images/OutliningIndicators/None.gif)
Dim
WSAD
As
WSADATA
Dim
sLoByte
As
String
Dim
sHiByte
As
String
If
WSAStartup(WS_VERSION_REQD, WSAD)
<>
ERROR_SUCCESS
Then
MsgBox
"
The 32-bit Windows Socket is not responding.
"
SocketsInitialize
=
False
Exit
Function
End
If
If
WSAD.wMaxSockets
<
MIN_SOCKETS_REQD
Then
MsgBox
"
This application requires a minimum of
"
&
_
CStr
(MIN_SOCKETS_REQD)
&
"
supported sockets.
"
SocketsInitialize
=
False
Exit
Function
End
If
If
LoByte(WSAD.wVersion)
<
WS_VERSION_MAJOR
Or
_
(LoByte(WSAD.wVersion)
=
WS_VERSION_MAJOR
And
_
HiByte(WSAD.wVersion)
<
WS_VERSION_MINOR)
Then
sHiByte
=
CStr
(HiByte(WSAD.wVersion))
sLoByte
=
CStr
(LoByte(WSAD.wVersion))
MsgBox
"
Sockets version
"
&
sLoByte
&
"
.
"
&
sHiByte
&
_
"
is not supported by 32-bit Windows Sockets.
"
SocketsInitialize
=
False
Exit
Function
End
If
'
must be OK, so lets do it
SocketsInitialize
=
True
End Function
2.在界面上添加2个textbox(Text1, Text2)和1个button(cmdGetMachineID)
Option Explicit
![](/Images/OutliningIndicators/None.gif)
Private Sub cmdGetMachineID_Click()
![](/Images/OutliningIndicators/None.gif)
Text1
=
GetIPHostName()
Text2
=
GetIPAddress()
![](/Images/OutliningIndicators/None.gif)
End Sub