How to get my computer IP address with VBA

[nector]

Hi all,

I'm trying to amend the code below to help me get the IP address from my computer IPV4 so that I do not need to worry about the dynamic changes of IP addresses each time I log in

The code below works for me, but it brings the unwanted extension instead of just only the IPaddress.

Function GetIPAddress()
    Const strComputer As String = "."   ' Computer name. Dot means local computer
    Dim objWMIService, IPConfigSet, IPConfig, IPAddress, i
    Dim strIPAddress As String

    ' Connect to the WMI service
    Set objWMIService = GetObject("winmgmts:" _
        & "{impersonationLevel=impersonate}!\\" & strComputer & "\root\cimv2")

    ' Get all TCP/IP-enabled network adapters
    Set IPConfigSet = objWMIService.ExecQuery _
        ("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled=TRUE")

    ' Get all IP addresses associated with these adapters
    For Each IPConfig In IPConfigSet
        IPAddress = IPConfig.IPAddress
        If Not IsNull(IPAddress) Then
            strIPAddress = strIPAddress & Join(IPAddress, ", ")
        End If
    Next

    GetIPAddress = strIPAddress
End Function

I will be running this code on an onload event

Me.txtIpaddress = GetIPAddress()

help me to cut off fe80:::d90:56f:dca8:5bb510.212.128.10

 

[pbaldy]

Use the Left() function in conjunction with InStr() to find the position of the first comma.

 

[KitaYama]

You can also query WMI without hassle :
Add a Reference to Microsoft Scripting Runtime
then run this:

Sub GetLocalIPAddress()
   
    Dim objWMIService As Object
    Dim Itms As Object
    Dim Itm As Object
    Dim IP As String

    Set objWMIService = GetObject("winmgmts:\\.\root\cimv2")
    Set Itms = objWMIService.ExecQuery("Select * from Win32_NetworkAdapterConfiguration Where IPEnabled = True")

    For Each Itm In Itms
        If Not IsNull(Itm.IPAddress) Then
            IP = Itm.IPAddress(0)
            Exit For
        End If
    Next Itm

    MsgBox "Local IP Address: " & IP
   
End Sub

 

[nector]

Many thanks to all respondents, well appreciated

 

[CJ_London]

You can also use the split method

Me.txtIpaddress =split( GetIPAddress(),”,”)(0)

 

[Minty]

Do you not need the external IP address?

We use a URL service that only returns the IPv4? Something like

 HttpRequest.Open "GET", "https://api.ipify.org/", False

 

[nector]

Many thanks for your advice, all

 

[Eugene-LS]

The code below works for me, but it brings the unwanted extension instead of just only the IPaddress.

Try use nslookup tool.

Sub testGetHostIPByName()
Dim sVal$
    sVal = Environ("COMPUTERNAME")
    sVal = GetHostIPByName(sVal)
    Debug.Print sVal
End Sub


Function GetHostIPByName(vHostName) As String
' es - 19.05.2023 v002
' Фукция возвращает IP-Адрес по имени доступного на д.м. Хоста с использованием утилиты nslookup
' The function returns the IP Address by name (available) Host using the nslookup utility
' -------------------------------------------------------------------------------------------------/
Dim objFSO As Object, objFSOFile As Object
Dim objTextStream As Object
Dim arrFileLines() As String, arrIPAdrValues() As String
Dim sHostName As String, sTempFilePath$, sVal$, iVal%, sFileStr$, sLineStr$, iPosWAN%, iPosLAN%
'---------------------------------------------------------------------------------------------------
On Error GoTo GetHostIPByName_Err
    
    If Len(vHostName & "") < 3 Then GoTo GetHostIPByName_End
    sHostName = Replace(vHostName, "\", "")
    
    Set objFSO = CreateObject("Scripting.FileSystemObject")

' see: https://learn.microsoft.com/ru-ru/office/vba/language/reference/user-interface-help/getspecialfolder-method
    sTempFilePath = objFSO.GetSpecialFolder(2)  ' Path to the user's TEMP folder
    If Len(sTempFilePath) < 3 Then sTempFilePath = CurrentProject.Path

' Путь к файлу результатов работы nslookup
' Path to the nslookup results file
    sTempFilePath = sTempFilePath & "\nslookup_Report.txt" ' Полный путь

' Запуск nslookup c сохранением результат в файле
' Run nslookup and save the result in a file
    sVal = "cmd /c nslookup " & sHostName & " > " & sTempFilePath
    CreateObject("Wscript.Shell").Run sVal, 0, True
' -------------------------------------------------------------------------------------------------/
' Чтение полученного файла:
' Reading the received file:
    Set objFSOFile = objFSO.GetFile(sTempFilePath)
    Set objTextStream = objFSOFile.OpenAsTextStream(1) 'OpenFileForReading = 1
    
    Do While Not objTextStream.AtEndOfStream
        sVal = Trim(objTextStream.ReadLine)
        ' Строки короче 8-ми символов (минимальная длинна IP) нам не интересны и мы их пропускаем
        ' Strings shorter than 8 characters (minimum IP length) are not interesting to us and we skip them
        If Len(Trim(sVal)) >= 8 Then
            sFileStr = sFileStr & vbNewLine & sVal
        End If
    Loop
    objTextStream.Close
    DoEvents
    
' Уборка первого перевода строки в блоке:
' Removing first line break in block
    If Len(sFileStr) > 3 Then
        sFileStr = Mid(sFileStr, 3)
    Else
        GoTo GetHostIPByName_End
    End If
 
' Очистка текста от пробелов и прочего мусора
' Cleaning text from spaces and other garbage
    sFileStr = Replace(sFileStr, " ", "")    ' Пробелы
    sFileStr = Replace(sFileStr, Chr(9), "") ' Chr(9) = TAB
' -------------------------------------------------------------------------------------------------/

' Определяем тип адреса(ов) : Если (iPosWAN > 0) их будет несколько
    iPosWAN = InStr(1, sFileStr, "Addresses:")
    
'Обрезаем начало строки до начала адреса(ов)
    Select Case iPosWAN 'Хост из аргумента в WAN (скорее всего) -у него несколько дресов
        Case Is > 0 ' Будет список адресов т.к. нашли строку "Addresses:" = Множ. число и
            sFileStr = Mid(sFileStr, iPosWAN + Len("Addresses:"))
        
        Case Else   ' Наверняка будет один адрес из локалной сети (LAN)
            iPosLAN = InStr(1, sFileStr, sHostName)
            'Debug.Print iPosLAN
            'Debug.Print sFileStr
            'Получаем адрес за именем нашего хоста с учётом что первод строки в конце ( + 2)
            If iPosLAN > 0 Then  'Начало строки адреса найдено
                sFileStr = Mid(sFileStr, iPosLAN + Len(sHostName) + 2)
                sFileStr = Replace(sFileStr, "Address:", "")
            Else 'Имя нашего хоста в списке LAN не найдено, а должно быть (не доступен)
                GoTo GetHostIPByName_End   'Амба! - проследуйте , уважаемые, на выход
            End If
    End Select
  
'Заполняем массив оставшимися после всех приключений (выше) строками для последующего анализа:
    arrFileLines = Split(sFileStr, vbNewLine, -1, vbTextCompare)

' Анализ :
    For iVal = LBound(arrFileLines) To UBound(arrFileLines)
        sLineStr = arrFileLines(iVal)
        arrIPAdrValues() = Split(sLineStr, ".") 'Получаем массив элементов адреса
        If UBound(arrIPAdrValues) = 3 Then ' В строке есть 4 значения разделённые точками!
            'Возвращаем первое же попавшееся (сильно похожее на IP-адрес) :
            GetHostIPByName = sLineStr ' на этом и всё ...
            GoTo GetHostIPByName_End   ' пожалуйте, уважаемые, на выход
            'Сами значения (между точками) пока не проверяем
            'For iVal = LBound(arrIPAdrValues) To UBound(arrIPAdrValues)
            '    Debug.Print iVal & " = " & arrIPAdrValues(iVal)
            'Next iVal
        End If
    Next iVal
' -------------------------------------------------------------------------------------------------/

GetHostIPByName_End:
    On Error Resume Next
    Set objFSO = Nothing
    Set objFSOFile = Nothing
    objTextStream.Close
    Set objTextStream = Nothing
    Err.Clear
    Exit Function
' -------------------------------------------------------------------------------------------------/
GetHostIPByName_Err:
    MsgBox "Error " & Err.Number & " (" & Err.Description & ") in Function :" & _
        "GetHostIPByName - mod00Test.", vbCritical, "Error!"
    'Debug.Print "GetHostIPByName_Line: " & Erl & "."
    Err.Clear
    Resume GetHostIPByName_End
End Function