Hi DORI,
I've setup a sheet with four groups that I have named Group 01~, Group
02~, Group 03~ and Group 04~ (you could extend it up to Group 99~).
I copied each group then did a paste special Picture (Enhanced
metafile). I then reduced each copy's size to make the four miniatures.
I renamed them Group 01~~, Group 02~~, Group 03~~ and Group 04~~.
With my first attempt I just copied each group and did an ordinary
paste for each miniature.
When I assigned these miniatures to my macro they failed to work
consistently. With office 2003 they have changed the way grouped shapes
respond when clicked, so I have had to use paste special to get the
miniatures to work consistently as macro buttons.
I then set up the following Worksheet_SelectionChange Event Sub...
Private Sub Worksheet_SelectionChange(ByVal Target As Excel.Range)
If Target.Cells(1, 1).Address = "$B$6" Then
Dim Shp As Shape
Dim logicalCanBeSeen As Boolean
For Each Shp In ActiveSheet.Shapes
If Right(Shp.Name, 2) = "~~" Then
Shp.Visible = Not (Shp.Visible)
logicalCanBeSeen = Shp.Visible
End If
Next Shp
Application.EnableEvents = False
If logicalCanBeSeen Then
With Range("B6")
.Value = "Click a Pic"
.Offset(-5, -1).Select
End With
Else: With Range("B6")
.Value = "Click Here"
.Offset(-5, -1).Select
End With
End If
Application.EnableEvents = True
End If
End Sub
When the user clicks in B6 the selection change triggers the macro
which looks for shapes with name ending in "~~", ie the miniatures.
When each is found, its visibility is toggled. This brings all the
miniatures into view (I have positioned them around B6.
Also, the text in B6 is changed. If the Miniatures are visible B6 will
show "Click a Pic", if invisible it will show "Click Here".
The code then selects A1. This has to be done, otherwise the next time
the user clicks in B6 it won't result in a selection change and the
code will not be executed. However, when coding a selection change
within a Worksheet_SelectionChange Event Sub, you must make sure the
code makes Application.EnableEvents = False before it then True after
it. If coding is not set up this way then it ends up in an endless
loop. You've experienced this before.
Each of the miniatures has been assigned to the following standard
macro.
(To assign a shape to a macro =>Right click miniature>select "assign
macro">select the macro from the list of macro names)
Public Sub GetUsersChoice()
Dim strUsersChoice As String
Dim Shp As Shape
Dim ncTildeGroups As New Collection
Dim shpChosen As Shape
Dim I As Integer
strUsersChoice = Application.Caller
Range("B6").Select
For Each Shp In ActiveSheet.Shapes
If Right(Shp.Name, 1) = "~" And Right(Shp.Name, 2) <> "~~" Then
ncTildeGroups.Add Item:=Shp
End If
Next Shp
For Each Shp In ncTildeGroups
If Shp.Name = Left(strUsersChoice, Len(strUsersChoice) - 1) Then
Set shpChosen = ActiveSheet.Shapes(Left(strUsersChoice,
Len(strUsersChoice) - 1))
Shp.Visible = True
Else: Shp.Visible = False
End If
Next Shp
Do While I < 360
I = I + 1
shpChosen.IncrementRotation 1
Calculate
Loop
End Sub
This macro is run after the user clicks on one of the miniatures.
The miniature that was clicked is identified by Application.Caller,
which returns the clicked miniature's name.
So, if the user clicked the miniature named Group 01~~, then
Application.Caller returns the string "Group 01~~".
Once the clicked miniature button has been determined the code then
selects B6, triggering the Worksheet_SelectionChange Events Sub, which
makes the miniatures invisible and changes the text in B6 to "Click
Here"
Now the code in the GetUsersChoice macro scans the sheet for the Groups
whose names end with ~ but not ~~ and adds those to a new collection
called ncTildeGroups.
The shapes in this collection are then searched for the one whose name
is the same as the clicked Miniature's name, ignoring the last ~. That
group is rendered visible, while the rest in that collection are
rendered invisible. I then show off a bit and make the visible shape do
a 360 degree rotation (Just for fun!).
I will email the sheet so that you have a better idea of how it works.
If you have any problems adapting this to your sheet don't hesitate
to email the sheet to me, along with any useful info, and I will do
what I can.
Ken Johnson
