Finding IP address using VBA & Windows 7

[martinr]

I have seen some VBA functions that return the IP address of the
PC (See sample below) but it only seems to work with Win XP.
Does anyone know how to achieve this with Windows 7?


' code sample ____________________________________________________
Dim IPAddress As String
Dim wsh As Object
Dim RegEx As Object, RegM As Object
Dim FSO As Object, fil As Object
Dim ts As Object, txtAll As String, TempFil As String

On Error GoTo GetLocIP
Set wsh = CreateObject("WScript.Shell")
Set FSO = CreateObject("Scripting.FileSystemObject")
Set RegEx = CreateObject("vbscript.regexp")
TempFile = "C:\myipaddress.txt"

wsh.Run "%comspec% /c ipconfig > " & TempFil, 0, True
With RegEx
.Pattern = "(\d{1,3}\.){3}\d{1,3}"
.Global = False
End With
Set fil = FSO.GetFile(TempFile)

Set ts = fil.OpenAsTextStream(1)
txtAll = ts.ReadAll
Set RegM = RegEx.Execute(txtAll)
GetLocIP = RegM(0)
ts.Close
Kill TempFil

Set ts = Nothing
Set wsh = Nothing
Set fil = Nothing
Set FSO = Nothing
Set RegM = Nothing
Set RegEx = Nothing
'end of example_________________________________

 

[jdraw]

I don't have WIN 7 but I have used this from Wayne Phillips with XP and Vista

' VBA MODULE: Get all IP Addresses of your machine
' (c) 2005 Wayne Phillips (http://www.everythingaccess.com)
' Written 18/05/2005
'
' REQUIREMENTS: Windows 98 or above, Access 97 and above
'
' Please read the full tutorial here:
' http://www.everythingaccess.com/tutorials.asp?ID=Get-all-IP-Addresses-of-your-machine
'
' Please leave the copyright notices in place.
' Thank you.
'
Option Compare Database
Option Explicit

'A couple of API functions we need in order to query the IP addresses in this machine
Public Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (Destination As Any, Source As Any, ByVal Length As Long)
Public Declare Function GetIpAddrTable Lib "Iphlpapi" (pIPAdrTable As Byte, pdwSize As Long, ByVal Sort As Long) As Long

'The structures returned by the API call GetIpAddrTable...
Type IPINFO
    dwAddr As Long         ' IP address
    dwIndex As Long         ' interface index
    dwMask As Long         ' subnet mask
    dwBCastAddr As Long     ' broadcast address
    dwReasmSize As Long    ' assembly size
    Reserved1 As Integer
    Reserved2 As Integer
End Type

Public Function ConvertIPAddressToString(longAddr As Long) As String
    
    Dim IPBytes(3) As Byte
    Dim lngCount As Long
    
    'Converts a long IP Address to a string formatted 255.255.255.255
    'Note: Could use inet_ntoa instead
    
    CopyMemory IPBytes(0), longAddr, 4 ' IP Address is stored in four bytes (255.255.255.255)
    
    'Convert the 4 byte values to a formatted string
    While lngCount < 4
    
        ConvertIPAddressToString = ConvertIPAddressToString + _
                                    CStr(IPBytes(lngCount)) + _
                                    IIf(lngCount < 3, ".", "")

        lngCount = lngCount + 1
        
    Wend
    
End Function

Public Sub GetIPAddresses(Optional blnFilterLocalhost As Boolean = False)

    Dim ret As Long, Tel As Long
    Dim bytBuffer() As Byte
    Dim IPTableRow As IPINFO
    Dim lngCount As Long
    Dim lngBufferRequired As Long
    Dim lngStructSize As Long
    Dim lngNumIPAddresses As Long
    Dim strIPAddress As String

On Error GoTo ErrorHandler:
    
    Call GetIpAddrTable(ByVal 0&, lngBufferRequired, 1)

    If lngBufferRequired > 0 Then
    
        ReDim bytBuffer(0 To lngBufferRequired - 1) As Byte
    
        If GetIpAddrTable(bytBuffer(0), lngBufferRequired, 1) = 0 Then
    
            'We've successfully obtained the IP Address details...
    
            'How big is each structure row?...
            lngStructSize = LenB(IPTableRow)
    
            'First 4 bytes is a long indicating the number of entries in the table
            CopyMemory lngNumIPAddresses, bytBuffer(0), 4
    
            While lngCount < lngNumIPAddresses
        
                'bytBuffer contains the IPINFO structures (after initial 4 byte long)
                CopyMemory IPTableRow, _
                            bytBuffer(4 + (lngCount * lngStructSize)), _
                            lngStructSize
                
                strIPAddress = ConvertIPAddressToString(IPTableRow.dwAddr)
                
                If Not ((strIPAddress = "127.0.0.1") _
                        And blnFilterLocalhost) Then
                        
                    'Replace this with whatever you want to do with the IP Address...
                    Debug.Print strIPAddress
                gIPAddrs = gIPAddrs & vbCrLf & strIPAddress
                End If
            
                lngCount = lngCount + 1
            
            Wend
        
        End If
        
    End If

Exit Sub

ErrorHandler:
    MsgBox "An error has occured in GetIPAddresses():" & vbCrLf & vbCrLf & _
            Err.Description & " (" & CStr(Err.number) & ")"

End Sub

'---------------------------------------------------------------------------------------
' Procedure : test_GetMyIP
' Author    : user
' Date      : 3/15/2008
' Purpose   : To use the GetIPAddresses procedure
'             to get all IP addresses on users machine,
' and to display the IPs in the immediate window, and
'to place the IP addresses into a Global Public variable
' with a CrLf between each IP address.
'---------------------------------------------------------------------------------------
'
Sub test_GetMyIP()
   On Error GoTo test_GetIP_Error

'Initialize the public variable - gIPAddrs - to Null
gIPAddrs = vbNullString
' Invoke the proc to get IP addresses
GetIPAddresses

'Display the results in a msgbox
MsgBox "IP addresses on this machine: " & gIPAddrs

   On Error GoTo 0
   Exit Sub

test_GetIP_Error:

    MsgBox "Error " & Err.number & " (" & Err.Description & ") in procedure test_MyGetIP of Module IPAddressStuff"
End Sub

 

[Galaxiom]

There are many old ways to get computer information but most have been superceded by Windows Management Interface queries which are far more concise.

This function returns the IP Address of all interfaces. I have seen similar code but it appears that the properties collection in Windows 7 is a little different and requires an underscore.

Public Function getIP()
 
Dim objWMIService As Object
Dim colItems As Object
Dim itm As Object
 
    Set objWMIService = GetObject("winmgmts:\root\cimv2")
    Set colItems = objWMIService.ExecQuery _
                   ("SELECT * FROM Win32_NetworkAdapterConfiguration WHERE IPEnabled = True")
    For Each itm In colItems
        getIP = getIP & itm.Properties_("IPAddress")(0) & vbCrLf
    Next
 
    Debug.Print getIP ' Included for testing only
End Function

 

[Mihail]

@Galaxiom
I think that you should edit your post in order to move the Debug.Print statement inside the For-Next cycle.

Thank you both ! It is also an unexpected help for me.

 

[Galaxiom]

The Debug.Print prints the return value of the function which is the complete concatenated IP addresses and a line feed between them.

 

[GBalcom]

Hello,
First off, thanks for the code above. I'm begining to digest the idea of obtaining the IP address. I'll need it to allow the IP of a users machine to access my SQL database in the cloud.
I'm completely new to the idea of pulling any information off of a users computer. Is silently obtaining the IP address a legal, moral thing to do? It sure would be easier than prompting them for it and hoping its right.


Also, the codes loops through and finds multiple IP addresses...I thought there was only one per computer? Can someone explain this?

Thanks!

 

[Galaxiom]

Is silently obtaining the IP address a legal, moral thing to do?

The originating IP Address is sent with every packet of data and is required for any communication with the machine. It is hardly a secret.

Also, the codes loops through and finds multiple IP addresses...I thought there was only one per computer? Can someone explain this?

Each interface has an IP address. The machine may have multiple physical interfaces as is common on servers for redundency. It may also have multiple virtual interfaces.

 

[GBalcom]

Thank you Galaxiom!

I'm looking into this further...it seems a Fully Qualified Domain name is the best answer....