How to fade out or make and image opaque

[samco]

I wondering if It is possible to make and image opaque when and event is triggered or change the contrast

 

[erik.van.geit]

For your information: I deleted a useless "Dim"-line from previous code

Hello,
it was a joy to create this
please run DEMO to see what it is doing

Option Explicit

Public sh1 As Shape
Public sh2 As Shape

Sub demo()
'Erik Van Geit
'050916 1300
Dim I As Integer
create_rectangles
    For I = 1 To 6
    perform
    Application.Wait Now + 2 / 60 / 60 / 24
    Next I
remove_rectangles
End Sub

Sub create_rectangles()
Const nm1 As String = "RectYel"
Const nm2 As String = "RectRed"

With ActiveSheet
    With .Shapes
    .AddShape(msoShapeRectangle, 48, 12.75, 96, 25.5).Name = nm1
    .AddShape(msoShapeRectangle, 48, 12.75, 96, 25.5).Name = nm2
    End With
Set sh1 = .Shapes(nm1)
Set sh2 = .Shapes(nm2)
End With

With sh1.Fill
.ForeColor.SchemeColor = 13
.Transparency = 1
End With
sh2.Fill.ForeColor.SchemeColor = 10

End Sub

Sub perform()
Dim I As Integer
Dim delay As Double
Dim starttime As Double
Dim Obj1 As Shape
Dim Obj2 As Shape

Set Obj1 = IIf(sh1.Fill.Transparency = 1, sh1, sh2)
Set Obj2 = IIf(sh2.Fill.Transparency = 1, sh1, sh2)

  For I = 1 To 100
  Obj1.Fill.Transparency = 1 - I / 100
  Obj2.Fill.Transparency = I / 100
    'delay = 0.1
    'starttime = Timer
    'Do
    DoEvents
    'Loop While Timer - starttime < delay
  Next I
End Sub

Sub remove_rectangles()
sh1.Delete
sh2.Delete
End Sub

you can create the objects manually or running the macro "create_rectangles" (you cannot run this macro twice without removing the objects first, since you cannot name a shape using a name already assigned to another shape else you could put in "on error resume next" and "on error goto 0")
everytime you open the workbook you need to run a macro to put the objects in memory for later use

With ActiveSheet
Set sh1 = .Shapes("RectYel")
Set sh2 = .Shapes("RectRed")
End With

you could put this in the workbook_open event

you can call the macro "perform" when you click the option button

kind regards,
Erik

 

[erik.van.geit]

after some more thoughts ...
this is more userfriendly
the rectangles will be created if they don't exist when the workbook opens, and anyway the variables sh1 and sh2 will be assigned for later use during the current session

Option Explicit

Public sh1 As Shape
Public sh2 As Shape
Public Const nm1 As String = "RectYel"
Public Const nm2 As String = "RectRed"
Public Const WsName As String = "sheet1"

Sub demo()
'Erik Van Geit
'050916 1300
Dim i As Integer
create_rectangles
    For i = 1 To 6
    perform
    Application.Wait Now + 2 / 60 / 60 / 24
    Next i
remove_rectangles
End Sub

Sub create_rectangles()
Dim tryout1 As Shape
Dim tryout2 As Shape

With Sheets(WsName)
    On Error Resume Next
    Set tryout1 = .Shapes(nm1)
    Set tryout2 = .Shapes(nm2)
    On Error GoTo 0
    With .Shapes
    If tryout1 Is Nothing Then .AddShape(msoShapeRectangle, 48, 12.75, 96, 25.5).Name = nm1
    If tryout2 Is Nothing Then .AddShape(msoShapeRectangle, 48, 12.75, 96, 25.5).Name = nm2
    End With
    On Error GoTo 0
Set sh1 = .Shapes(nm1)
Set sh2 = .Shapes(nm2)
End With

With sh1.Fill
.ForeColor.SchemeColor = 13
.Transparency = 1
End With
sh2.Fill.ForeColor.SchemeColor = 10

End Sub

Sub perform()
Dim i As Integer
Dim delay As Double
Dim starttime As Double
Dim Obj1 As Shape
Dim Obj2 As Shape

Set Obj1 = IIf(sh1.Fill.Transparency = 1, sh1, sh2)
Set Obj2 = IIf(sh2.Fill.Transparency = 1, sh1, sh2)

  For i = 1 To 100
  Obj1.Fill.Transparency = 1 - i / 100
  Obj2.Fill.Transparency = i / 100
    'delay = 0.1
    'starttime = Timer
    'Do
    DoEvents
    'Loop While Timer - starttime < delay
  Next i
End Sub

Sub remove_rectangles()
sh1.Delete
sh2.Delete
End Sub

Private Sub Workbook_Open()
create_rectangles
End Sub

best regards,
Erik

 

[samco]

Cool feature

This is useful all round..Thanks