Word VBA檢索IP地址「靜默」

Question

我需要將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 

更新，發現使用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 

Answer 1

我認爲這可能會更容易，它使用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 

Answer 2

方法你試過這個代碼？

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

編輯：感謝Belizarius。

下面是代碼:(測試和爲我工作，從以上來源採取）。

在代碼末尾示例（函數MyIP）。

希望它有幫助！

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