All geek questions in one place

Word VBA to get the IP address "silently"

I need to pull the IP address into a VBA macro. This code works, but the command dialog is briefly visible, which doesn’t look very good. Can I use a modification to make it quiet?

Sub getIP() Set objShell = CreateObject("WScript.Shell") Set objExecObject = objShell.Exec("%comspec% /c ipconfig.exe") Do Until objExecObject.StdOut.AtEndOfStream strLine = objExecObject.StdOut.ReadLine() strIP = InStr(strLine, "Address") If strIP <> 0 Then IPArray = Split(strLine, ":") strIPAddress = IPArray(1) End If Loop SynapseForm.LabelIP.Caption = strIPAddress End Sub

Update , found an option using Wscript.Shell to write to a temporary file, this works “quietly” not as good as the Remou method below

  Sub getIPAddress() Dim IP_Address: IP_Address = GetIP() If IP_Address = "0.0.0.0" Or IP_Address = "" Then MsgBox "No IP Address found.", , "" Else MsgBox IP_Address 'MsgBox IP_Address, , "IP address" End If End Sub Function GetIP() Dim ws: Set ws = CreateObject("WScript.Shell") Dim fso: Set fso = CreateObject("Scripting.FileSystemObject") Dim TmpFile: TmpFile = fso.GetSpecialFolder(2) & "/ip.txt" Dim ThisLine, IP If ws.Environment("SYSTEM")("OS") = "" Then ws.Run "winipcfg /batch " & TmpFile, 0, True Else ws.Run "%comspec% /c ipconfig > " & TmpFile, 0, True End If With fso.GetFile(TmpFile).OpenAsTextStream Do While Not .AtEndOfStream ThisLine = .ReadLine If InStr(ThisLine, "Address") <> 0 Then IP = Mid(ThisLine, InStr(ThisLine, ":") + 2) End If Loop .Close End With 'WinXP (NT? 2K?) leaves a carriage return at the end of line If IP <> "" Then If Asc(Right(IP, 1)) = 13 Then IP = Left(IP, Len(IP) - 1) End If GetIP = IP fso.GetFile(TmpFile).Delete Set fso = Nothing Set ws = Nothing End Function
+4
source share
2 answers

I think it might be easier, it uses WMI.

 strComputer = "." Set objWMIService = GetObject("winmgmts:\\" & strComputer & "\root\CIMV2") Set colItems = objWMIService.ExecQuery( _ "SELECT * FROM Win32_NetworkAdapterConfiguration", , 48) For Each objItem In colItems If Not IsNull(objItem.IPAddress) Then ''Commented line ''Debug.Print "IPAddress: " & Join(objItem.IPAddress, ",") ''Message box MsgBox "IPAddress: " & Join(objItem.IPAddress, ",") ''String for later use strIPAddress = strIPAddress & Join(objItem.IPAddress, ",") End If Next ''Later SynapseForm.LabelIP.Caption = strIPAddress
+5
source

Have you tried this code?

Edit: Thank you, Belizear.

Here is the code: (tested and working for me, taken from the above sources).

An example at the end of the code (MyIP function).

Hope this helps!

 Private Declare Function GetComputerName Lib "kernel32" _ Alias "GetComputerNameA" _ (ByVal lpBuffer As String, nSize As Long) As Long ' ******** Code Start ******** 'This code was originally written by Dev Ashish. 'It is not to be altered or distributed, 'except as part of an application. 'You are free to use it in any application, 'provided the copyright notice is left unchanged. ' 'Code Courtesy of 'Dev Ashish ' Private Const MAX_WSADescription = 256 Private Const MAX_WSASYSStatus = 128 Private Const AF_INET = 2 Private Type WSADATA wversion As Integer wHighVersion As Integer szDescription(MAX_WSADescription) As Byte szSystemStatus(MAX_WSASYSStatus) As Byte wMaxSockets As Long wMaxUDPDG As Long dwVendorInfo As Long End Type Private Type HOSTENT hName As Long hAliases As Long hAddrType As Integer hLength As Integer hAddrList As Long End Type ' returns the standard host name for the local machine Private Declare Function apiGetHostName _ Lib "wsock32" Alias "gethostname" _ (ByVal name As String, _ ByVal nameLen As Long) _ As Long ' retrieves host information corresponding to a host name ' from a host database Private Declare Function apiGetHostByName _ Lib "wsock32" Alias "gethostbyname" _ (ByVal hostname As String) _ As Long ' retrieves the host information corresponding to a network address Private Declare Function apiGetHostByAddress _ Lib "wsock32" Alias "gethostbyaddr" _ (addr As Long, _ ByVal dwLen As Long, _ ByVal dwType As Long) _ As Long ' moves memory either forward or backward, aligned or unaligned, ' in 4-byte blocks, followed by any remaining bytes Private Declare Sub sapiCopyMem _ Lib "kernel32" Alias "RtlMoveMemory" _ (Destination As Any, _ Source As Any, _ ByVal Length As Long) ' converts a string containing an (Ipv4) Internet Protocol ' dotted address into a proper address for the IN_ADDR structure Private Declare Function apiInetAddress _ Lib "wsock32" Alias "inet_addr" _ (ByVal cp As String) _ As Long ' function initiates use of Ws2_32.dll by a process Private Declare Function apiWSAStartup _ Lib "wsock32" Alias "WSAStartup" _ (ByVal wVersionRequired As Integer, _ lpWsaData As WSADATA) _ As Long Private Declare Function apilstrlen _ Lib "kernel32" Alias "lstrlen" _ (ByVal lpString As Long) _ As Long Private Declare Function apilstrlenW _ Lib "kernel32" Alias "lstrlenW" _ (ByVal lpString As Long) _ As Long ' function terminates use of the Ws2_32.dll Private Declare Function apiWSACleanup _ Lib "wsock32" Alias "WSACleanup" _ () As Long Function fGetHostIPAddresses(strHostName As String) As Collection ' ' Resolves the English HostName and returns ' a collection with all the IPs bound to the card ' On Error GoTo ErrHandler Dim lngRet As Long Dim lpHostEnt As HOSTENT Dim strOut As String Dim colOut As Collection Dim lngIPAddr As Long Dim abytIPs() As Byte Dim i As Integer Set colOut = New Collection If fInitializeSockets() Then strOut = String$(255, vbNullChar) lngRet = apiGetHostByName(strHostName) If lngRet Then Call sapiCopyMem( _ lpHostEnt, _ ByVal lngRet, _ Len(lpHostEnt)) Call sapiCopyMem( _ lngIPAddr, _ ByVal lpHostEnt.hAddrList, _ Len(lngIPAddr)) Do While (lngIPAddr) With lpHostEnt ReDim abytIPs(0 To .hLength - 1) strOut = vbNullString Call sapiCopyMem( _ abytIPs(0), _ ByVal lngIPAddr, _ .hLength) For i = 0 To .hLength - 1 strOut = strOut & abytIPs(i) & "." Next strOut = Left$(strOut, Len(strOut) - 1) .hAddrList = .hAddrList + Len(.hAddrList) Call sapiCopyMem( _ lngIPAddr, _ ByVal lpHostEnt.hAddrList, _ Len(lngIPAddr)) If Len(Trim$(strOut)) Then colOut.Add strOut End With Loop End If End If Set fGetHostIPAddresses = colOut ExitHere: Call apiWSACleanup Set colOut = Nothing Exit Function ErrHandler: With Err MsgBox "Error: " & .Number & vbCrLf & .Description, _ vbOKOnly Or vbCritical, _ .Source End With Resume ExitHere End Function Function fGetHostName(strIPAddress As String) As String ' ' Looks up a given IP address and returns the ' machine name it bound to ' On Error GoTo ErrHandler Dim lngRet As Long Dim lpAddress As Long Dim strOut As String Dim lpHostEnt As HOSTENT If fInitializeSockets() Then lpAddress = apiInetAddress(strIPAddress) lngRet = apiGetHostByAddress(lpAddress, 4, AF_INET) If lngRet Then Call sapiCopyMem( _ lpHostEnt, _ ByVal lngRet, _ Len(lpHostEnt)) fGetHostName = fStrFromPtr(lpHostEnt.hName, False) End If End If ExitHere: Call apiWSACleanup Exit Function ErrHandler: With Err MsgBox "Error: " & .Number & vbCrLf & .Description, _ vbOKOnly Or vbCritical, _ .Source End With Resume ExitHere End Function Private Function fInitializeSockets() As Boolean Dim lpWsaData As WSADATA Dim wVersionRequired As Integer wVersionRequired = fMakeWord(2, 2) fInitializeSockets = ( _ apiWSAStartup(wVersionRequired, lpWsaData) = 0) End Function Private Function fMakeWord( _ ByVal low As Integer, _ ByVal hi As Integer) _ As Integer Dim intOut As Integer Call sapiCopyMem( _ ByVal VarPtr(intOut) + 1, _ ByVal VarPtr(hi), _ 1) Call sapiCopyMem( _ ByVal VarPtr(intOut), _ ByVal VarPtr(low), _ 1) fMakeWord = intOut End Function Private Function fStrFromPtr( _ pBuf As Long, _ Optional blnIsUnicode As Boolean) _ As String Dim lngLen As Long Dim abytBuf() As Byte If blnIsUnicode Then lngLen = apilstrlenW(pBuf) * 2 Else lngLen = apilstrlen(pBuf) End If ' if it not a ZLS If lngLen Then ReDim abytBuf(lngLen) ' return the buffer If blnIsUnicode Then 'blnIsUnicode is True not tested Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen) fStrFromPtr = abytBuf Else ReDim Preserve abytBuf(UBound(abytBuf) - 1) Call sapiCopyMem(abytBuf(0), ByVal pBuf, lngLen) fStrFromPtr = StrConv(abytBuf, vbUnicode) End If End If End Function ' ******** Code End ******** Function ReturnComputerName() As String Dim rString As String * 255 Dim sLen As Long Dim tString As String tString = "" On Error Resume Next sLen = GetComputerName(rString, 255) sLen = InStr(1, rString, Chr(0)) If sLen > 0 Then tString = Left(rString, sLen - 1) Else tString = rString End If On Error GoTo 0 ReturnComputerName = UCase(Trim(tString)) End Function Public Function MyIP() As String Debug.Print fGetHostIPAddresses(ReturnComputerName).item(1) End Function
+1
source

Source: https://habr.com/ru/post/1339390/

More articles:


All Articles