如何统计访问数据库的人数和IP地址？

获取电脑IP、电脑名、电脑用户名

Option Compare Database


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