How to control image transparency?

Question

I have an image in my worksheet I want to fade out.

I am tying to set different stages of transparency for the image:

Set myPicture = ActiveSheet.Pictures.Insert(pic)

With myPicture
    .Transparency = 0.5
    Application.Wait (Now + TimeValue("00:00:01"))
    .Transparency = 0.3
    Application.Wait (Now + TimeValue("00:00:01"))
    .Transparency = 0.1
    Application.Wait (Now + TimeValue("00:00:01"))
    .Delete
End With

I get an error message.

object not supported

Answer 1

It took me a long time to get this to work (until I tried the DoEvents)

Sub FadeInFadeOut()
    Dim r As Range
    Set r = Selection
    ActiveSheet.Shapes("Rectangle 1").Select
    Selection.ShapeRange.Fill.Transparency = 1

    For i = 1 To 100
        Selection.ShapeRange.Fill.Transparency = 1 - i / 100
        DoEvents
    Next

    For i = 1 To 100
        Selection.ShapeRange.Fill.Transparency = i / 100
        DoEvents
    Next

    r.Select
End Sub

It works on an AutoShape I place on the sheet.

NOTE:

You must adjust the 100 to adjust the fade-in / fade-out speed.

EDIT#1:

Here is some junk code (based on the Recorder) for dropping an AutoShape on a sheet and filling it with a Picture:

Sub PicturePlacer()
    Dim sh As Shape

    ActiveSheet.Shapes.AddShape(msoShapeRectangle, 312.75, 176.25, 266.25, 129.75). _
        Select

    Selection.Name = "Sargon"

    Application.CommandBars("AutoShapes").Visible = False
    Range("G4").Select
    ActiveCell.FormulaR1C1 = "123"
    Range("G5").Select
    ActiveSheet.Shapes("Sargon").Select
    Selection.ShapeRange.Fill.Transparency = 0.56
    Selection.ShapeRange.Line.Weight = 0.75
    Selection.ShapeRange.Line.DashStyle = msoLineSolid
    Selection.ShapeRange.Line.Style = msoLineSingle
    Selection.ShapeRange.Line.Transparency = 0#
    Selection.ShapeRange.Line.Visible = msoTrue
    Selection.ShapeRange.Line.ForeColor.SchemeColor = 64
    Selection.ShapeRange.Line.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.Fill.Visible = msoTrue
    Selection.ShapeRange.Fill.ForeColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.Fill.BackColor.RGB = RGB(255, 255, 255)
    Selection.ShapeRange.Fill.UserPicture "C:\Users\garys\Pictures\babies.jpeg"
End Sub

Remember to Name the Shape and use that Name in all the codes that reference that Shape.

Answer 2

I just ran across this excellent routine last week and tried it. The only downfall I noticed is that because the shape is Selected, when the For ... Next loops run the Selection Handles are visible on the shape. I also saw the question posted by Princess.Bell: "is there anyway to add a background image to the shape?" I have an update to this posting which addresses both issues. I also slowed the fade in and fade out by adjusting the "timer" in the For ... Next loops from 100 to 250. This allows the fade in and fade out process to take place over 0.5 second.

Sub FadeInFadeOut()
    Dim shp As Shape
    Set shp = Sheets("Sheet1").Shapes.AddShape(Type:=msoShapeRectangle, _
              Left:=35, Top:=117, Width:=72.75, Height:=25.5)

    Dim i As Integer

    With shp.Fill
        .Visible = msoTrue
        .UserPicture FileName  '==> C:\Users\Me\AppData\Local\Temp\SavedImage.jpg (image file)
        For i = 1 To 250  'Fade in shape/picture.
        .Transparency = 1 - i / 250
            DoEvents
    Next
        For i = 1 To 250  'Fade out shape/picture.
        .Transparency = i / 250
        DoEvents
        Next
    End With
    shp.Delete  'Discard the shape now that we're done using it.
    Range("C3").Select  'Position cursor.
End Sub