[AccessD] Obtaining IP Address

Sample code below from Seth Galitzer.

Thanks,

Mark


Option Compare Database
Option Explicit

'---Start Code---


Const conMaxSize = 255
Const WSADESCRIPTION_LEN = 256
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


Private Declare Function WSAStartup Lib "wsock32" _
    (ByVal VersionReq As Long, WSADataReturn As WSADATA) As Long


Private Declare Function WSACleanup Lib "wsock32" () As Long


Private Declare Function WSAGetLastError Lib "wsock32" () As Long


Private Declare Function GetHostByName Lib "wsock32" Alias _
    "gethostbyname" (ByVal HostName As String) As Long


Private Declare Sub RtlMoveMemory Lib "kernel32" _
    (hpvDest As Any, ByVal hpvSource As Long, ByVal cbCopy As Long)


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


'Comments  : checks if string is valid IP address
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:23:26 AM
Private Function IsIP(ByVal strIP As String) As Boolean
On Error GoTo Err_IsIP
    On Error Resume Next
    Dim t As String: Dim s As String: Dim i As Integer
    s = strIP
    While InStr(s, ".") <> 0
        t = Left(s, InStr(s, ".") - 1)
        If IsNumeric(t) And Val(t) >= 0 And Val(t) <= 255 Then
            s = Mid(s, InStr(s, ".") + 1)
        Else
            Exit Function
        End If
        i = i + 1
    Wend
    t = s
    If IsNumeric(t) And InStr(t, ".") = 0 And Len(t) = 
Len(Trim(Str(Val(t)))) And _
        Val(t) >= 0 And Val(t) <= 255 And strIP <> "255.255.255.255" And i = 
3 _
        Then IsIP = True
Exit_IsIP:
Exit Function


Err_IsIP:
    Select Case err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox err & ": " & err.Description, , "Error in function 
clsIP_Tools.IsIP"
    Resume Exit_IsIP
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function


'Comments  : resolves host name to IP address
'Parameters:
'Sets      :
'Returns   :
'Created by: Unknown
'Mod. by   : Seth D. Galitzer
'Created   : 7/20/00 9:27:00 AM
Private Function AddrByName(ByVal strHost As String) As String
On Error GoTo Err_AddrByName
    On Error Resume Next
    Dim hostent_addr As Long
    Dim hst As hostent
    Dim hostip_addr As Long
    Dim temp_ip_address() As Byte
    Dim i As Integer
    Dim ip_address As String
    If IsIP(strHost) Then
        AddrByName = strHost
        Exit Function
    End If
    hostent_addr = GetHostByName(strHost)
    If hostent_addr = 0 Then
        err.Raise 9001, , "Can't resolve host"
    End If
    RtlMoveMemory hst, hostent_addr, LenB(hst)
    RtlMoveMemory hostip_addr, hst.hAddrList, 4
    ReDim temp_ip_address(1 To hst.hLength)
    RtlMoveMemory temp_ip_address(1), hostip_addr, hst.hLength
    For i = 1 To hst.hLength
        ip_address = ip_address & temp_ip_address(i) & "."
    Next
    ip_address = Mid(ip_address, 1, Len(ip_address) - 1)
    AddrByName = ip_address
Exit_AddrByName:
Exit Function


Err_AddrByName:
    Select Case err
    Case 0      'insert Errors you wish to ignore here
        Resume Next
    Case Else   'All other errors will trap
        Beep
        MsgBox err & ": " & err.Description, , "Error in function 
clsIP_Tools.AddrByName"
    Resume Exit_AddrByName
    End Select
    Resume 0    'FOR TROUBLESHOOTING
End Function


Public Function basGetOwnIP() As String
    Dim udtWSAData As WSADATA
    Dim strName As String


    If WSAStartup(257, udtWSAData) Then
        err.Raise err.LastDllError, , err.Description
    End If


    strName = Space(conMaxSize)


    GetComputerName strName, conMaxSize
    basGetOwnIP = AddrByName(Left(strName, InStr(strName, vbNullChar) - 1))


    WSACleanup

'---End Code---


End Function



>From: "JWColby" <jwcolby at colbyconsulting.com>
>Reply-To: Access Developers discussion and problem 
>solving<accessd at databaseadvisors.com>
>To: "'Access Developers discussion and problem 
>solving'"<accessd at databaseadvisors.com>,   <dba-vb at databaseadvisors.com>
>Subject: [AccessD] Obtaining IP Address
>Date: Thu, 22 Mar 2007 09:59:18 -0400
>
>Is there VBA code out there to obtain the IP address of the current
>workstation?  I found code that goes through the registry, and it ALMOST
>works, in fact it does work in many instances but...
>
>John W. Colby
>Colby Consulting
>www.ColbyConsulting.com
>
>--
>AccessD mailing list
>AccessD at databaseadvisors.com
>http://databaseadvisors.com/mailman/listinfo/accessd
>Website: http://www.databaseadvisors.com

_________________________________________________________________
The average US Credit Score is 675. The cost to see yours: $0 by Experian. 
http://www.freecreditreport.com/pm/default.aspx?sc=660600&bcd=EMAILFOOTERAVERAGE