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

在我的工作地点，不同的计算机位于不同的子网中，如果PC与Samba服务器位于同一个子网中，则可以通过\\myserv\MyFolder访问文件服务器，但是PC位于不同的子网，我到达服务器的唯一方法是使用IP (ie, \\1.2.3.4\MyFolder) 。

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

如果我可以使用\\myservfind服务器，那么使用myserv ，否则使用1.2.3.4 ？

不幸的是，我根本无法调整networking，我想这样设置，至less在IP更改时，大多数用户仍然可以通过访问\\myserv\MyFolder来使用该工具。

假设你在Windows环境下，这里有一个替代方法（没有实际的代码）：

  1. 在Excel VBA中，使用SHELL函数执行Net Viewfunction并将输出发送到文件。 即： 
 Dim vsFileName vsFileName = "C:\Temp\RandomFileName.txt" Shell("Net View \\myServ > " & vsFileName )
  1. 之后，检查输出的文件大小。 如果输出文件大小> 0，表示findpath。 如果找不到path，则输出文件大小将为0。

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

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

如果你不想使用win32函数，这是一个select。 每次运行代码时，随机化文件名是一个好主意，以避免冲突。

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

我已经对代码进行了评论，所以希望你能理解这个代码是否需要调整。 它根据我使用的示例子工作。 我会让你做networkingpath检查后设置文件夹的代码;）

这不是一个简单的任务，但它是一个棘手的问题，所以我很高兴分享代码。 从您要调用的函数开始，检查path是如何定义的。 我已经在我的networking上testing过了，它们都可以正常工作，通过networking名称和IP检查Diskstation： 

 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 "[AZ]" 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

然后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

然后通用的networkingfunction： 

  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
Interesting Posts