none
PowerPoint - Macro to Change Fill from Results of PING Command RRS feed

  • Question

  • Hello Everyone,

    Has anyone written a macro that would change the fill color of a circle, line and such type object depending on the results of a PING command?  I am limited to using the programs and utilities within the MS Office suite to accomplish this.  Can't use other third party programs like IPSwitch's Whatsup?


    Thanks, CAZan

    Wednesday, July 5, 2017 6:30 PM

All replies

  • You can use this to ping.  No utilities or programs need to be installed:

    Function PingOK() As Boolean
    
      Dim objPing As Object
      Dim objItem As Object
      Dim done As Boolean
      Dim cnt As Integer
      
      done = False
      cnt = 1
      PingOK = False
    
      Do While Not done And cnt <= 4
        Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                      ExecQuery("select * from Win32_PingStatus " & _
                      "where address = '" & "www.google.com" & "'")
                      
        cnt = cnt + 1
                      
        For Each objItem In objPing
          If objItem.StatusCode = 0 Then
            PingOK = True
            done = True
          End If
        Next objItem
      Loop
    End Function
    

    Thursday, July 6, 2017 12:15 AM
  • Hi mogulman52,

    I do not see where the ping test changes the fill color of a shape/object.  If there is more than one shape, how is the macro associated with the item?


    Thanks, CAZan


    • Edited by CAZan Thursday, July 6, 2017 4:27 PM correction
    Thursday, July 6, 2017 4:26 PM
  • I just showed you how to ping a website.  You'll need to add code to search for the shape and change its color.  In the code below I create a textbox and change its foreground color based on the results of the ping. 

    Sub test()
      ActivePresentation.Slides(1).Select
      With ActiveWindow.Selection
        .SlideRange.Shapes.AddTextBox(msoTextOrientationHorizontal, 10, 10, 100, 100).Select
        .ShapeRange.TextFrame.AutoSize = ppAutoSizeNone
        .ShapeRange.Line.Visible = msoTrue
        .ShapeRange.Fill.Visible = msoTrue
        .ShapeRange.Fill.Solid
        If PingOK Then
          .ShapeRange.Fill.ForeColor.RGB = RGB(0, 0, 255)
        Else
          .ShapeRange.Fill.ForeColor.RGB = RGB(255, 0, 0)
        End If
      End With
    
    End Sub
    
    Function PingOK() As Boolean
    
      Dim objPing As Object
      Dim objItem As Object
      Dim done As Boolean
      Dim cnt As Integer
      
      done = False
      cnt = 1
      PingOK = False
    
      Do While Not done And cnt <= 4
        Set objPing = GetObject("winmgmts:{impersonationLevel=impersonate}"). _
                      ExecQuery("select * from Win32_PingStatus " & _
                      "where address = '" & "www.google.com" & "'")
                      
        cnt = cnt + 1
                      
        For Each objItem In objPing
          If objItem.StatusCode = 0 Then
            PingOK = True
            done = True
          End If
        Next objItem
      Loop
    End Function
    

    Friday, July 7, 2017 5:15 PM
  • Thanks mogulman52,

    This a start.  I haven't work much with VBA lately, but I have been doing a lot with VBS.  So, I have to work on understanding the syntax more and adapt it to my needs.  I was wondering if it could be done.

    What I want to do is to associate the macro to a line or circle to create a simple network activity status map using a MS Office program.  Your code creates an object.  However, in my scenario, the object is already created.  I just need to be able to associate a PING of an IP address. Upon those results change the objects color green or red.


    Thanks, CAZan

    Sunday, July 9, 2017 8:23 PM
  • When you create an object in PP it gives it a name.  You can rename it.

    Steps to name object:

    Unselect all objects
    Go to Home >> Arrange >> Selection Pane
    Double click object and rename it.

    Make sure you create naming rules.  I've had problems when adding new objects.  PP also creates an Id property but you can only access that in VBA.

    Here is how to iterate through the objects.   Open the immediate window to view results.  This should be enough to get you started. 

    Sub test()
      Dim curSlide As Slide
      Dim curShape As Shape
    
      For Each curSlide In ActivePresentation.Slides
        Debug.Print "Current Slide: " & curSlide.Id
        For Each curShape In curSlide.Shapes
          Debug.Print curShape.Name & ", " & curShape.Id
        Next curShape
      Next curSlide
    End Sub
    

    As you iterate through you can check the name or Id, do a ping, and change the color.  If possible, you should try to use the Id.  It is always unique and shouldn't cause problems.

    I assume you keep a database of nodes to connect to so you can do something like:

    Sub Test2()
      Dim curShape
    
    '  Loop through database of objects
      curShape = GetShapeByName(curShapeName, curSlideNum)
      If PingOK(curIP) Then   'Change PingOK to accept IP address
        curShape.Fill.ForeColor.RBG = RGB(0, 0, 255)
      Else
        curShape.Fill.ForeColor.RGB = RGB(255, 0, 0)
      End If
    ' end loop
    
    End Sub
    
    Function GetShapeByName(shapeName As String, Slide As Integer)
        Set GetShapeByName = ActivePresentation.Slides(Slide).Shapes(shapeName).Select
    End Function
    
    


    Monday, July 10, 2017 3:59 PM