change colour of picture based on cell value

mickyflash

Board Regular
Joined
Jan 29, 2009
Messages
77
hello again guys

I have found this video of Bills that explains how I could dynamically change the .width & .Height of a shape in excel, but I am struggling to convert this to the shapes colour?

There would be only 2 options, if the linked cell is = to TRUE to view the picture In colour, or greyscale if FALSE

Thanks in advance for your help
 
Code amended to refer to image in URL.Offset(0, 4) instead of the last shape inserted
Error handling added in case VBA cannot find linked image

VBA Code:
Public Sub Add_Images_To_Cells()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim lastRow As Long, shp As Shape, s As Long
    Dim URLs As Range, URL As Range
    With ActiveSheet
        .Pictures.Delete
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        Set URLs = .Range("A2:A" & lastRow)

            For Each URL In URLs
                URL.Offset(0, 4).Select
                .Pictures.Insert URL.Value
                DoEvents
                If Err.Number <> 0 Then
                    On Error GoTo 0
                Else
                    For s = .Shapes.Count To 1 Step -1
                        Set shp = .Shapes(s)
                        If ActiveCell.Address = shp.TopLeftCell.Address Then
                            If Not URL.Offset(, 1) Then shp.PictureFormat.ColorType = 2
                            Exit For
                        End If
                    Next s
                End If
        Next URL
   End With
End Sub
 
Upvote 0

Excel Facts

Pivot Table Drill Down
Double-click any number in a pivot table to create a new report showing all detail rows that make up that number
- is any event code triggered when cell values change in the sheet ?
- look in the sheet code module or in ThisWorkbook module
- I can amend the code without the anser but I would like to understand what is going on behind the scenes

oops, yes I do have this code that runs the macro upon a cell change in C2

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    If Not Intersect(Target, Range("C2")) Is Nothing Then Add_Images_To_Cells
End Sub
 
Upvote 0
Code amended to refer to image in URL.Offset(0, 4) instead of the last shape inserted
Error handling added in case VBA cannot find linked image

VBA Code:
Public Sub Add_Images_To_Cells()
    On Error Resume Next
    Application.ScreenUpdating = False
    Dim lastRow As Long, shp As Shape, s As Long
    Dim URLs As Range, URL As Range
    With ActiveSheet
        .Pictures.Delete
        lastRow = .Cells(Rows.Count, "A").End(xlUp).Row
        Set URLs = .Range("A2:A" & lastRow)

            For Each URL In URLs
                URL.Offset(0, 4).Select
                .Pictures.Insert URL.Value
                DoEvents
                If Err.Number <> 0 Then
                    On Error GoTo 0
                Else
                    For s = .Shapes.Count To 1 Step -1
                        Set shp = .Shapes(s)
                        If ActiveCell.Address = shp.TopLeftCell.Address Then
                            If Not URL.Offset(, 1) Then shp.PictureFormat.ColorType = 2
                            Exit For
                        End If
                    Next s
                End If
        Next URL
   End With
End Sub

I am getting a 'Insert method of Picture class failed' run time error with this code relating to this line:
Code:
.Pictures.Insert URL.Value
 
Upvote 0
I am getting a 'Insert method of Picture class failed' run time error with this code

That should be your original code in a slightly different form. I do not understand why it should make a difference, but simply reinstate your original code as follows

Replace...
.Pictures.Insert URL.Value
with....
URL.Parent.Pictures.Insert URL.Value
 
Upvote 0
oops, yes I do have this code that runs the macro upon a cell change in C2

VBA Code:
Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Range("C2")) Is Nothing Then Add_Images_To_Cells
End Sub

Until we resolve everything please DISABLE above sub. A simple way to achieve that is to rename it. I usually insert 3 x's before the name
Private Sub xxxWorksheet_Change(ByVal Target As Range)
 
Upvote 0
this is all I get now :(


Capture.PNG
 
Upvote 0
Worksheet_change has been deleted.

I have run this code from post #2
VBA Code:
Sub Toggle()
    Const G = msoPictureGrayscale
    Const A = msoPictureAutomatic
    With ActiveSheet.Shapes("Picture 999").PictureFormat
        If .ColorType = G Then .ColorType = A Else .ColorType = G
    End With

End Sub

which works when you change "Picture 999" to the correct NAME
 
Upvote 0
Apologies, I meant your 2nd post ( the code you posted in post#3)
 
Upvote 0

Forum statistics

Threads
1,213,546
Messages
6,114,253
Members
448,556
Latest member
peterhess2002

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