Word VBA to retrieve IP address "silently"
I need to pull out the IP address into a VBA macro. This code works but the command dialogue is briefly visible which is not a good look. Can I use a modification to do it "silently" ?
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 a variant using Wscript.Shell to write to a temp file, this works "silently" not as nice as Remou's 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 /ba开发者_高级运维tch " & 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
I think this may 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
Have you tried this code?
- http://www.mvps.org/access/api/api0067.htm (computer IP)
- http://www.ozgrid.com/forum/showthread.php?t=28020&page=1 (computer name)
Edit: Thanks Belizarius.
Here's the code: (tested and working for me, taken from above sources).
Sample at the end of the code (function MyIP).
Hope it 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's 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's 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
精彩评论