在Access中获取本机IP地址、电脑名及开机登录用户名

时　间:2018-01-29 23:34:06
作　者:林岚   ID：3651  城市：中卫
摘　要:在Access中获取本机IP地址、电脑名及开机登录用户名
正　文:

 

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 = 128

 

Private Type HOSTENT

hName As Long

hAliases As Long

hAddrType As Integer

hLength As Integer

hAddrList As Long

End Type

 

Private 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 Type

 

Declare Function wu_GetUserName Lib "advapi32.dll" Alias "GetUserNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Declare Function wu_GetComputerName Lib "kernel32.dll" Alias "GetComputerNameA" (ByVal lpBuffer As String, nSize As Long) As Long

Private 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 ap_GetComputerName() As Variant

Dim strComputerName As String

Dim lngLength As Long

Dim lngResult As Long

 

strComputerName = String(255, 0)

lngLength = 255

 

lngResult = wu_GetComputerName(strComputerName, lngLength)

ap_GetComputerName = Left(strComputerName, InStr(1, strComputerName, Chr(0)) - 1)

 

End Function

 

Function ap_GetUserName() As Variant

Dim strUserName As String

Dim lngLength As Long

Dim lngResult As Long

 

strUserName = String(255, 0)

lngLength = 255

 

lngResult = wu_GetUserName(strUserName, lngLength)

ap_GetUserName = Left(strUserName, InStr(1, strUserName, Chr(0)) - 1)

 

End Function

Function GetComputerIP() As String

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 vntTemp As Variant

 

SocketsInitialize

 

hostent_addr = gethostbyname(vntTemp)

 

If hostent_addr = 0 Then

MsgBox "Can't resolve name."

Exit Function

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

GetComputerIP = GetComputerIP & temp_ip_address(I) & "."

Next

GetComputerIP = Mid$(GetComputerIP, 1, Len(GetComputerIP) - 1)

 

SocketsCleanup

End Function

 

Function hibyte(ByVal wParam As Integer)

hibyte = wParam \ &H100 And &HFF&

End Function

 

Function lobyte(ByVal wParam As Integer)

lobyte = wParam And &HFF&

End Function

 

Sub 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 Sub

 

Sub SocketsCleanup()

Dim lReturn As Long

 

lReturn = WSACleanup()

 

If lReturn <> 0 Then

MsgBox "Socket error " & Trim$(Str$(lReturn)) & " occurred in Cleanup "

End

End If

 

End Sub

Access软件网QQ交流群 (群号:483923997) 　　　　　　Access源码网店