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

Jasvinder_22

New Member
Joined
Sep 5, 2022
Messages
3
Office Version
  1. 365
  2. 2016
  3. 2010
Platform
  1. Windows
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
 

Excel Facts

Best way to learn Power Query?
Read M is for (Data) Monkey book by Ken Puls and Miguel Escobar. It is the complete guide to Power Query.
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):
VBA Code:
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
 
Upvote 0
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):
VBA Code:
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
 
Upvote 0
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.

VBA Code:
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
 
Upvote 0
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.

VBA Code:
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
 
Upvote 0
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.
VBA Code:
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:
VBA Code:
   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.
 
Upvote 0

Forum statistics

Threads
1,223,275
Messages
6,171,123
Members
452,381
Latest member
Nova88

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top