确定是否使用excel vba连接到VPN或Office Intranet或Office Wifi

Question

我有以下代码，可以用来成功检查我是否在家中连接到VPN以访问公司网络文件夹。

Sub doit()
    If ConnectedToVPN Then
    ' run other code to access network folders and files...
    End if
End Sub


Function ConnectedToVPN() As Boolean
   Dim sComputer$, oWMIService, colItems, objItem

   ConnectedToVPN = False
   sComputer = "."

   Set oWMIService = GetObject("winmgmts:\\" & sComputer & "\root\CIMV2")
   Set colItems = oWMIService.ExecQuery("SELECT * FROM Win32_NetworkAdapterConfiguration", , 48)

    'Please check description of your VPN Connection by running command "ipconfig /all" on command-line.

    For Each objItem In colItems
        If (InStr(LCase(objItem.Description), "vpn")) Then
            ConnectedToVPN = objItem.IPEnabled
        End If
    Next objItem

    If (ConnectedToVPN) Then ConnectedToVPN = True

End Function

但是，如果我在公司办公室中并且使用LAN电缆或办公室WIFI连接到Intranet，则无需连接到VPN。这样，我无法使我的代码正常工作。

我尝试了以下操作，但没有给我正确的结果：

• objItem.ServiceName
• objItem.DNSDomain

所以objItem properties将确定我已经通过Office Wifi或Office LAN连接到Intranet。例如属性来确定我连接的State和type of Adapter，即Wifi，Ethernet等？

Answer 1

无法对服务器执行ping操作吗？如果您在办公室或通过VPN连接，则应执行ping操作。如果您未连接，它将无法回答。

Dim PingResults As Object
Dim PingResult As Variant
Dim Query As String
Dim Host As String

Host = "YourFileServerHostName"
Query = "SELECT * FROM Win32_PingStatus WHERE Address = '" & Host & "'"

Set PingResults = GetObject("winmgmts://./root/cimv2").ExecQuery(Query)

For Each PingResult In PingResults
    If Not IsObject(PingResult) Then
        Ping = False
    ElseIf PingResult.StatusCode = 0 Then
        Ping = True
    Else
        Ping = False
    End If
Next