Excel/VBA - 检测服务器是否可达

Excel/VBA - Detect if server is reachable

提问by AZhu

At my work place, different computers are in different subnets, and if the PCs are in the same subnet as the Samba server, I can reach the file server by going to \\myserv\MyFolder, but for the PC is in a different subnet, the only way for me to reach the server is by using IP (i.e., \\1.2.3.4\MyFolder).

在我工作的地方，不同的电脑在不同的子网中，如果电脑和Samba服务器在同一个子网，我可以通过访问文件服务器\\myserv\MyFolder，但是对于PC在不同的子网中，唯一的方法是我到达服务器是通过使用 IP (i.e., \\1.2.3.4\MyFolder)。

I am just wondering in VBA, if there is any way I can say:

我只是想知道在 VBA 中，如果有什么办法可以说：

if I can find the server using \\myserv, then use myserv, else use 1.2.3.4?

如果我可以找到使用的服务器\\myserv，则使用myserv，否则使用1.2.3.4？

Unfortunately I can not tweak the network at all and I want to set up this way so that at least when the IP changes, majority of my users could still use the tool by visiting \\myserv\MyFolder.

不幸的是，我根本无法调整网络，我想以这种方式进行设置，以便至少在 IP 更改时，我的大多数用户仍然可以通过访问\\myserv\MyFolder.

采纳答案by Joseph Lee

Assuming you are on Windows environment, here's an alternative approach (without the actual code):

假设您在 Windows 环境中，这里有一种替代方法（没有实际代码）：

1. In Excel VBA, use the SHELL function to execute a Net View function and send the output to a file. ie:

1. 在 Excel VBA 中，使用 SHELL 函数执行 Net View 函数并将输出发送到文件。IE：

Dim vsFileName
vsFileName = "C:\Temp\RandomFileName.txt"
Shell("Net View \myServ > " & vsFileName )

Dim vsFileName
vsFileName = "C:\Temp\RandomFileName.txt"
Shell("Net View \myServ > " & vsFileName )

1. After that, check the filesize of the output. If output file size > 0, meaning the path is found. If the path cannot be found, the output filesize will be 0.

2. 之后，检查输出的文件大小。如果输出文件大小 > 0，则表示找到了路径。如果找不到路径，则输出文件大小将为 0。

If FileLen( vsFileName ) = 0 Then vsNetworkPath = "1.2.3.4"

If FileLen( vsFileName ) = 0 Then vsNetworkPath = "1.2.3.4"

1. Clean up after yourself by: Kill( vsFileName )

3. 通过以下方式清理自己： Kill( vsFileName )

This is an alternative if you don't want to mess around with win32 functions. It's a good idea to randomize the filename each time you run the code to avoid clashes.

如果您不想弄乱 win32 函数，这是一种替代方法。每次运行代码时随机化文件名以避免冲突是个好主意。

回答by CuberChase

Here is some code I use to check for server reachablility. It uses Windows winsock32 APIs and I haven't had any problems with it. I don't have to worry about privledges so I don't know how it'd handle that.

这是我用来检查服务器可达性的一些代码。它使用 Windows winsock32 API，我没有遇到任何问题。我不必担心特权，所以我不知道它会如何处理。

I've commented the code a fair bit so hopefully you'll understand whats going on should you need to tweak it. It with work as per the example sub I've used. I'll let you do the code that sets the folder after the network path is checked ;)

我已经对代码进行了相当多的评论，因此希望您能理解需要调整它时发生了什么。它按照我使用的示例子工作。我会让你在检查网络路径后执行设置文件夹的代码；)

This isn't a trivial task but it's a tricky problem so I'm happy to share the code. Start with the functions you'll call to do the check - note how the paths are defined. I've tested these on my network and they all work, the Diskstation is checked by its network name and its IP:

这不是一项微不足道的任务，但这是一个棘手的问题，所以我很高兴分享代码。从您将调用以进行检查的函数开始 - 请注意路径是如何定义的。我已经在我的网络上测试了这些，它们都可以正常工作，Diskstation 通过其网络名称和 IP 进行检查：

Sub TestMyPaths()
    TestPath ("C:\")
    TestPath ("\Diskstation\")
    TestPath ("\192.168.99.5\")
End Sub

Sub TestPath(sServerName As String)
    If sServerName = "" Then Exit Sub

    If Not CheckPath(sServerName) Then
        MsgBox "Cannot find " & sServerName
    Else
        MsgBox "Found " & sServerName
    End If
End Sub


Private Function CheckPath(sfile As String) As Boolean
    'Response Variables
    Dim bResponse As Boolean, bLocal As Boolean
    'File System Variables
    Dim oFS As Object, oDrive As Object, oTemp As Object
    'Variables for chkecing the server
    Dim strIPAddress  As String, Reply As ICMP_ECHO_REPLY, lngSuccess As Long, sServer As String

    If sfile = "" Then Exit Function
    bResponse = False

    On Error GoTo SomeProblem

    ' Determine if drive is local and resolve all remote paths to UNC filenames
    Set oFS = CreateObject("Scripting.FileSystemObject")
    Set oDrive = oFS.Drives
    bLocal = False
    If UCase(VBA.Left(sfile, 1)) Like "[A-Z]" Then
        For Each oDrive In oFS.Drives
            If oDrive.Path = UCase(VBA.Left(sfile, 2)) Then
                If oDrive.DriveType = 3 Then ' Remote Drive
                    sfile = Replace(sfile, (VBA.Left(sfile, 2)), oDrive.ShareName)
                Else
                    bLocal = True
                End If
                Exit For
            End If
        Next oDrive
    End If

    If bLocal Then
        'Allow for checking at the end of this if statement
        bResponse = True
    ElseIf VBA.Left(sfile, 1) <> "\" Then
        ' File Name only specified / Not a valid path
        bResponse = False
    Else
        'Otherwise we are dealing with a server path

        'Get the server name
        sServer = VBA.Mid$(sfile, 3, InStr(3, sfile, "\", vbTextCompare) - 3)

        'Set up networking to check
        If SocketsInitialize() Then
            strIPAddress = GetIPFromHostName(sServer)   'Get the ipaddress of the server name
            lngSuccess = ping(strIPAddress, Reply)      'Ping the IP that is passing the address and get a reply.
            Call WSACleanup                             'Clean up the sockets.
            If lngSuccess = 0 Then bResponse = True     'If we get a ping back we're all good
        End If
    End If

SomeProblem:
    CheckPath = bResponse
    Set oTemp = Nothing
    Set oDrive = Nothing
End Function

Then API declarations (these go at the top of your module).

然后是 API 声明（这些位于模块的顶部）。

    #If Win64 Then
        Private Declare PtrSafe Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname As String) As Long
        Private Declare PtrSafe Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
        Private Declare PtrSafe Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
        Private Declare PtrSafe Function WSACleanup Lib "WSOCK32.DLL" () As Long
    #Else
        Private Declare Function gethostbyname Lib "WSOCK32.DLL" (ByVal hostname As String) As Long
        Private Declare Sub CopyMemory Lib "kernel32" Alias "RtlMoveMemory" (xDest As Any, xSource As Any, ByVal nbytes As Long)
        Private Declare Function WSAStartup Lib "WSOCK32.DLL" (ByVal wVersionRequired As Long, lpWSADATA As WSADATA) As Long
        Private Declare Function WSACleanup Lib "WSOCK32.DLL" () As Long
    #End If

    'NETWORK AND PING API FUNCTIONS
    #If Win64 Then
        Public Declare PtrSafe Function IcmpCreateFile Lib "icmp.dll" () As Long
        Public Declare PtrSafe Function inet_addr Lib "WSOCK32.DLL" (ByVal cp As String) As Long
        Public Declare PtrSafe Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
        Private Declare PtrSafe Function IcmpSendEcho Lib "icmp.dll" _
           (ByVal IcmpHandle As Long, _
            ByVal DestinationAddress As Long, _
            ByVal RequestData As String, _
            ByVal RequestSize As Long, _
            ByVal RequestOptions As Long, _
            ReplyBuffer As ICMP_ECHO_REPLY, _
            ByVal ReplySize As Long, _
            ByVal Timeout As Long) As Long
    #Else
        Public Declare Function IcmpCreateFile Lib "icmp.dll" () As Long
        Public Declare Function inet_addr Lib "WSOCK32.DLL" (ByVal cp As String) As Long
        Public Declare Function IcmpCloseHandle Lib "icmp.dll" (ByVal IcmpHandle As Long) As Long
        Private Declare Function IcmpSendEcho Lib "icmp.dll" _
           (ByVal IcmpHandle As Long, _
            ByVal DestinationAddress As Long, _
            ByVal RequestData As String, _
            ByVal RequestSize As Long, _
            ByVal RequestOptions As Long, _
            ReplyBuffer As ICMP_ECHO_REPLY, _
            ByVal ReplySize As Long, _
            ByVal Timeout As Long) As Long
    #End If

    Public Const WINSOCK_ERROR = "Windows Sockets not responding correctly."
    Public Const INADDR_NONE As Long = &HFFFFFFFF
    Public Const WSA_SUCCESS = 0
    Public Const GWL_STYLE = -16
    Public Const WS_SYSMENU = &H80000
    Private Const ICMP_SUCCESS As Long = 0
    Private Const WS_VERSION_REQD As Long = &H101
    Private Const MAX_WSADescription As Long = 256
    Private Const MAX_WSASYSStatus As Long = 128

    'PING AND NETWORK ENUMS
    Private Type IP_OPTION_INFORMATION
       Ttl             As Byte
       Tos             As Byte
       Flags           As Byte
       OptionsSize     As Byte
       OptionsData     As Long
    End Type

    Public Type ICMP_ECHO_REPLY
       Address         As Long
       Status          As Long
       RoundTripTime   As Long
       DataSize        As Long
       Reserved        As Integer
       ptrData                 As Long
       Options        As IP_OPTION_INFORMATION
       data            As String * 250
    End Type

    Private Type WSADATA
        wVersion As Integer
        wHighVersion As Integer
        szDescription(0 To MAX_WSADescription) As Byte
        szSystemStatus(0 To MAX_WSASYSStatus) As Byte
        wMaxSockets As Long
        wMaxUDPDG As Long
        dwVendorInfo As Long
    End Type

And then the generic network functions:

然后是通用网络功能：

    Public Function GetIPFromHostName(ByVal sHostName As String) As String
        'converts a host name to an IP address.
        Dim ptrHosent As Long  'address of hostent structure
        Dim ptrName As Long    'address of name pointer
        Dim ptrAddress As Long    'address of address pointer
        Dim ptrIPAddress As Long
        Dim sAddress As String
        sAddress = Space$(4)
        ptrHosent = gethostbyname(sHostName & vbNullChar)
        If ptrHosent <> 0 Then
            ptrName = ptrHosent
            ptrAddress = ptrHosent + 12
            'get the IP address
            CopyMemory ptrName, ByVal ptrName, 4
            CopyMemory ptrAddress, ByVal ptrAddress, 4
            CopyMemory ptrIPAddress, ByVal ptrAddress, 4
            CopyMemory ByVal sAddress, ByVal ptrIPAddress, 4
            GetIPFromHostName = IPToText(sAddress)
        End If
    End Function

    Private Function IPToText(ByVal IPAddress As String) As String
        IPToText = CStr(Asc(IPAddress)) & "." & _
                   CStr(Asc(Mid$(IPAddress, 2, 1))) & "." & _
                   CStr(Asc(Mid$(IPAddress, 3, 1))) & "." & _
                   CStr(Asc(Mid$(IPAddress, 4, 1)))
    End Function

    Public Function SocketsInitialize() As Boolean
        Dim WSAD As WSADATA
        SocketsInitialize = WSAStartup(WS_VERSION_REQD, WSAD) = ICMP_SUCCESS
    End Function

    Public Function ping(sAddress As String, Reply As ICMP_ECHO_REPLY) As Long
        'Function to ping an address and see if a response is obtained
        Dim hIcmp As Long, lAddress As Long, lTimeOut As Long, StringToSend As String

        StringToSend = "test"           'Short string of data to send
        lTimeOut = 1000 'ms             'ICMP (ping) timeout
        lAddress = inet_addr(sAddress)  'Convert string address to a long representation

        'If we have a valid response
        If (lAddress <> -1) And (lAddress <> 0) Then

            'Create the handle for ICMP requests.
            hIcmp = IcmpCreateFile()

            If hIcmp Then
                'Ping the destination IP address.
                Call IcmpSendEcho(hIcmp, lAddress, StringToSend, Len(StringToSend), 0, Reply, Len(Reply), lTimeOut)

                'Reply status
                ping = Reply.Status

                'Close the Icmp handle.
                IcmpCloseHandle hIcmp
            Else
                Debug.Print "failure opening icmp handle."
                ping = -1
            End If
        Else
            ping = -1
        End If
    End Function