vba 控制图像透明度可能吗？

Question

I have an image in my worksheet that i want to fade out. To do this i am tying to find a way of setting different stages of transparency for the image like so:

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

At the moment i get a object not supported error message which leads me to believe this may not be possible.

If possible, please can somoene show me how to do this? Thanks

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