Word VBA“静默”检索IP地址

Word VBA to retrieve IP address "silently"

提问by Saul

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" ?

我需要将 IP 地址提取到 VBA 宏中。此代码有效，但命令对话框是短暂可见的，这看起来不太好。我可以使用修改来“默默地”吗？

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

更新，发现了一个使用 Wscript.Shell 写入临时文件的变体，这“静默”地工作，不如下面 Remou 的方法好

    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

回答by Fionnuala

I think this may be easier, it uses WMI.

我认为这可能更容易，它使用 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

回答by Tiago Cardoso

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)

• http://www.mvps.org/access/api/api0067.htm（电脑IP）
• http://www.ozgrid.com/forum/showthread.php?t=28020&page=1（计算机名）

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).

代码末尾的示例（函数 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