Tactical-Tech.net

C4Pinger adds WhatsUp Gold like functionality to your network diagram for about $14,000 less than Whats Up Gold. Since it's free, we call it the Cheap 4th-point-of-contact Pinger or C4Pinger.

Download NetworkFileCardV7 and C4Pinger

Since it is cheap, and Visio is somewhat limited in its functionality, there is a bit of work that goes along with getting this to work. I couldn't find away to link the VBA to the stencil and still have the C4PingSwitch execute the code, so the code has to be associated with the document its running on.

This will only work with NetworkFileCardV7 (and maybe one day above), but you are able to set the "pingability" status of each file card and the ping intervals. C4Pinger will identify the filecards that fail to respond to a ping by changing the color from white, to yellow, orange and then red (which means dead).

For those that want to view the code before the download, here it is:

#If VBA7 Then
    Declare PtrSafe Sub Sleep Lib "kernel32" _
    (ByVal dwMilliseconds As Long)
    
#Else
    Declare Sub Sleep Lib "kernel32" Alias "Sleep" _
    (ByVal dwMilliseconds As Long)
#End If

Function PingState()
    Dim shp As Shape
    If Not (ActivePage Is Nothing) Then
        For Each shp In ActivePage.Shapes
        
            DoEvents
            
            If (shp.CellExists("User.Reputation", Visio.visExistsAnywhere)) Then
                If (shp.CellExists("Prop.InterfaceAIP", visExistsLocally)) Then Set CellObj = shp.Cells("Prop.InterfaceAIP")
                If (shp.CellExists("prop.modemIP", visExistsLocally)) Then Set CellObj = shp.Cells("prop.modemIP")
             
                pingable = shp.Cells("prop.pingable")
                
                If (pingable) Then
                       
                    IP = CellObj.ResultStr("")
                    IP = FormatIP(IP)
                                    
                    pingStatus = GetPingResult(IP)
                    reputation = shp.Cells("user.reputation")
                    
                    
                    If (pingStatus = 0) Then
                        reputation = IIf((reputation + 2 > 10), 10, reputation + 2)
                    Else
                        reputation = IIf((reputation - 1 < 0), 0, reputation - 1)
                    End If
                    shp.Cells("user.reputation") = reputation
                    
                    
                    Select Case reputation
                    Case 10
                         shp.Cells("FillForegnd") = 1
                         
                    Case 7 To 9
                         shp.Cells("FillForegnd").FormulaU = "RGB(252, 239, 84)"
                    Case 4 To 6
                         shp.Cells("FillForegnd").FormulaU = "RGB(254, 146, 31)"
                    Case Else
                         shp.Cells("FillForegnd") = 2
                         
                    End Select
                    
                    Set IP = Nothing
                    
                    Set pingable = Nothing
                    
                End If
               
            End If
          
            If (shp.CellExists("Prop.PingIntervals", visExistsAnywhere)) Then
                
                Set CellObj = shp.Cells("Prop.Continue")
                continue = (CellObj.ResultStr(""))
               
            End If
                                
        Next
        
        
        
        
        PingState = continue
        
        
    End If
    Set CellObj = Nothing
    
End Function

Function GetPingResult(Host)
    'pings IP address
   Dim objPing As Object
   Dim objStatus As Object
   Dim strResult As String
    DoEvents
   Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
       ExecQuery("Select * from Win32_PingStatus Where timeout = 1200 and Address = '" & Host & "'")

For Each objStatus In objPing
      GetPingResult = objStatus.StatusCode
   Next

Set objPing = Nothing
   Set objStatus = Nothing

End Function

Function FormatIP(IP)
    'removes Cider notation from IP field
    
    If (InStr(IP, "/")) Then
        charFromLeft = InStr(IP, "/") - 1
        IP = Left(IP, charFromLeft)
    ElseIf (InStr(IP, "")) Then
        charFromLeft = InStr(IP, "") - 1
        IP = Left(IP, charFromLeft)
    End If
    
    FormatIP = Trim(IP)

End Function

Public Sub UpdatePingState(seconds)
    
    Do While PingState()
        
        Do While Now() < wait
            DoEvents
        Loop
        wait = DateAdd("s", seconds, Now)
         
    Loop
   
    
End Sub