VBA Code to display image in place of message "ON" or "OFF" as output of ping

[Jasvinder_22]

Function Ping(strip)
Dim objshell, boolcode
Set objshell = CreateObject("Wscript.Shell")
boolcode = objshell.Run("ping -n 1 -w 1000 " & strip, 0, True)
If boolcode = 0 Then
Ping = True
Else
Ping = False
End If
End Function

Sub PingSystem()
Dim strip As String
Do Until Sheet1.Range("F1").Value = "STOP"
Sheet1.Range("F1").Value = "TESTING"
For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
strip = ActiveSheet.Cells(introw, 2).Value
If Ping(strip) = True Then
ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 0, 0)
ActiveSheet.Cells(introw, 3).Value = "Online"
Application.Wait (Now + TimeValue("0:00:01"))
ActiveSheet.Cells(introw, 3).Font.Color = RGB(0, 200, 0)
Else
ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 0
ActiveSheet.Cells(introw, 3).Font.Color = RGB(200, 0, 0)
ActiveSheet.Cells(introw, 3).Value = "Offline"
Application.Wait (Now + TimeValue("0:00:01"))
ActiveSheet.Cells(introw, 3).Interior.ColorIndex = 6
End If
If Sheet1.Range("F1").Value = "STOP" Then
Exit For
End If
Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

Sub stop_ping()
Sheet1.Range("F1").Value = "STOP"
End Sub

 

[portews]

This code depends on a couple of things.
1. The image files are available to the machine the code is being run on
2. The images are sized correctly, otherwise, put the correct pixel values in the width and height criteria.

Try this (not fully tested):

ub PingSystem()
Dim strip As String
Dim ws As Worksheet
Dim imagePath As String
Set ws = ActiveSheet

Do Until Sheet1.Range("F1").Value = "STOP"
Sheet1.Range("F1").Value = "TESTING"
For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
strip = ActiveSheet.Cells(introw, 2).Value

If Ping(strip) = True Then
    imagePath = "C:\Pics\True.png"
Else
    imagePath = "C:\Pics\False.png"
End If

'Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
    Filename:=imagePath, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=ActiveSheet.Cells(introw, 3).Left, _
    Top:=ActiveSheet.Cells(introw, 3).Top, _
    Width:=-1, _
    Height:=-1

If Sheet1.Range("F1").Value = "STOP" Then
Exit For
End If
Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

 

[Jasvinder_22]

This code depends on a couple of things.
1. The image files are available to the machine the code is being run on
2. The images are sized correctly, otherwise, put the correct pixel values in the width and height criteria.

Try this (not fully tested):

ub PingSystem()
Dim strip As String
Dim ws As Worksheet
Dim imagePath As String
Set ws = ActiveSheet

Do Until Sheet1.Range("F1").Value = "STOP"
Sheet1.Range("F1").Value = "TESTING"
For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
strip = ActiveSheet.Cells(introw, 2).Value

If Ping(strip) = True Then
    imagePath = "C:\Pics\True.png"
Else
    imagePath = "C:\Pics\False.png"
End If

'Width & Height = -1 means keep original size
ws.Shapes.AddPicture _
    Filename:=imagePath, _
    LinkToFile:=msoFalse, _
    SaveWithDocument:=msoTrue, _
    Left:=ActiveSheet.Cells(introw, 3).Left, _
    Top:=ActiveSheet.Cells(introw, 3).Top, _
    Width:=-1, _
    Height:=-1

If Sheet1.Range("F1").Value = "STOP" Then
Exit For
End If
Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

Hi,

The provided code is working and inserting the image in specified cell but the challenge while running the code is that the each time I run the code it paste image in said cell and there are number of copies of image, the number of times the code is being run. Needs only single image each time code is activated and delete all the previous images stored in provided cell. My image is just a Green/Red Light image to show the success/failure of ping command.

Also wants to center align image in cell

Waiting for your positive response

 

[portews]

This will delete ALL the images on the worksheet. You may have to play with the left and top properties to get the image to go where you want it, depending on the size of the image. I set the height and width to be the cell height, assuming it is symmetrical. You may have to play with that as well.

Sub PingSystem()
Dim strip As String
Dim ws As Worksheet
Dim imagePath As String
Dim shp As Shape
Dim cWdth As Variant
Dim RHeight As Variant


Set ws = ActiveSheet

For Each shp In ws.Shapes
   shp.Delete
Next shp

'find the column width where the image will go
cWdth = Range("C").ColumnWidth

Do Until Sheet1.Range("F1").Value = "STOP"
    Sheet1.Range("F1").Value = "TESTING"
    For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
        strip = ActiveSheet.Cells(introw, 2).Value
        'find the height of the row where the image will go
        RHeight = Range("C" & introw).RowHeight
        
        If Ping(strip) = True Then
            imagePath = "C:\Pics\True.png"
        Else
            imagePath = "C:\Pics\False.png"
        End If
        
        'Width & Height = -1 means keep original size
        ws.Shapes.AddPicture _
            Filename:=imagePath, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=ActiveSheet.Cells(introw, 3).Left + (cWdth / 2), _
            Top:=ActiveSheet.Cells(introw, 3).Top, _
            Width:=RHeight, _
            Height:=RHeight
        
        If Sheet1.Range("F1").Value = "STOP" Then
            Exit For
        End If
    Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

 

[Jasvinder_22]

This will delete ALL the images on the worksheet. You may have to play with the left and top properties to get the image to go where you want it, depending on the size of the image. I set the height and width to be the cell height, assuming it is symmetrical. You may have to play with that as well.

Sub PingSystem()
Dim strip As String
Dim ws As Worksheet
Dim imagePath As String
Dim shp As Shape
Dim cWdth As Variant
Dim RHeight As Variant


Set ws = ActiveSheet

For Each shp In ws.Shapes
   shp.Delete
Next shp

'find the column width where the image will go
cWdth = Range("C").ColumnWidth

Do Until Sheet1.Range("F1").Value = "STOP"
    Sheet1.Range("F1").Value = "TESTING"
    For introw = 2 To ActiveSheet.Cells(65536, 2).End(xlUp).Row
        strip = ActiveSheet.Cells(introw, 2).Value
        'find the height of the row where the image will go
        RHeight = Range("C" & introw).RowHeight
       
        If Ping(strip) = True Then
            imagePath = "C:\Pics\True.png"
        Else
            imagePath = "C:\Pics\False.png"
        End If
       
        'Width & Height = -1 means keep original size
        ws.Shapes.AddPicture _
            Filename:=imagePath, _
            LinkToFile:=msoFalse, _
            SaveWithDocument:=msoTrue, _
            Left:=ActiveSheet.Cells(introw, 3).Left + (cWdth / 2), _
            Top:=ActiveSheet.Cells(introw, 3).Top, _
            Width:=RHeight, _
            Height:=RHeight
       
        If Sheet1.Range("F1").Value = "STOP" Then
            Exit For
        End If
    Next
Loop
Sheet1.Range("F1").Value = "IDLE"
End Sub

On updating the code provided, it removes all the objects on excel sheet (even the start and stop button created) and the ping loop is endless with multiple overwritten images(image multiple copies available). Also the image is not center aligned. Kindly check and revert

 

[portews]

As I said, it will delete _ALL_ shapes. I have no idea what else is on the sheet.

To have it only delete pictures, substitute this code. Again, I have no idea what other picture shapes you have on the sheet.

For Each shp In ws.Shapes
   If shp.Type = msoPicture Then shp.Delete
Next shp

If you have other picture shapes you don't want deleted, you'll have to find their names and exclude them from the delete, something like:

   If shp.Type = msoPicture and not shp.Name = "Picture 102" Then shp.Delete

The reason the loop is endless is, in your original code, you're not setting F1 to "STOP", you're not calling stop_ping anywhere I can see. I have no idea what is happening with that code or under what conditions you want it to stop. That's up to you.

As far as the centering goes, you may have to adjust the "Left" criteria to get it to work. I don't know what the image properties are.