Graphics: Same Picture on several sheets

[brucemc]

I want to place a picture from a bitmap on, say, sheet 5, and then have it appear in sizable boxes on sheets 1, 2, 3 & 4. This way if I wish to change it, I can simply change it in one place (sheet 5) and it will flow through to all the other pages. What is the best way (Is there a good way) to handle this?

[Michael]

Hi brucemc. Check out the McGimpsey site at
http://www.mcgimpsey.com/excel/lookuppics.html . You might be able to use
this to display your picture.
--
Sincerely, Michael Colvin


"brucemc" wrote:

>
> I want to place a picture from a bitmap on, say, sheet 5, and then have
> it appear in sizable boxes on sheets 1, 2, 3 & 4. This way if I wish to
> change it, I can simply change it in one place (sheet 5) and it will
> flow through to all the other pages. What is the best way (Is there a
> good way) to handle this?
>
>
> --
> brucemc
> ------------------------------------------------------------------------
> brucemc's Profile: http://www.excelforum.com/member.php...o&userid=32871
> View this thread: http://www.excelforum.com/showthread...hreadid=550040
>
>

[brucemc]

I really liked learning from that example!

Unfortunately... Though it certainly would allow the switching of pictures I wish to achieve, unless I am missing a concept you might be presuming I already understand, I would have to have the entire collection of pictures on each sheet which I want them to appear (i.e.: the same four pictures on sheet1, sheet2, sheet3 and sheet4). I fear that will unnecessarily significantly increase file size.

I think what I want to do should be done by having the collection all on one sheet then echoed or reflected (OK, copied) onto all the other sheets on each change of the controlling variable. Unfortunately a simple copy routine won't work, even if it would copy the picture, unless I could learn how to not only copy the picture to each of the other sheets, but also individually specify the dimensions, as it does vary somewhat by sheet, and delete the previous.

I had hoped there was a way to set up a frame or shape on each sheet, then address it with VBA to change which picture that was to appear in it, with the pictures all stored as named Pictures (named ranges?) on one sheet. I will have to tinker with this, but if someone knows how to do it offhand, saving me hours of cussing is appreciated; and that is in addition to the hours of my wife cussing at me.

[brucemc]

Not possible, eh?

[brucemc]

I think I'm up a creek. Ain't no paddle. Never was. Never will be.

[Ken Johnson]

brucemc wrote:
> I think I'm up a creek. Ain't no paddle. Never was. Never will be.

Hi Bruce,
So that you don't have to have a copy of every picture on every sheet,
you can have every picture on Sheet1 with code determining which one is
visible. The code can also copy the visible picture onto every other
sheet and delete the previous visible picture.

I've used a WorksheetChange event procedure and a standard procedure to
control the visibility of all the pictures. I renamed the pictures
MyPic001, MyPic002 and MyPic003. I have limited myself to 3 pictures,
but naming them this way gives enough room for 1000 pictures (MyPic000
to MyPic999).
I renamed the pictures this way...

1. Select a picture
2. Click in the Name box on the left side of the formula bar
3. Type required name eg MyPic003
4. Press Enter (I too often forget this step. Try not to forget it,
otherwise the picture's name will not change and it will be ignored by
the code)

After all the pictures have been renamed and positioned exactly where
you want them to appear on Sheet1 the ensuing code does the
following...

If you change the value in A1 on Sheet1 to say 3 then the picture named
MyPic003 will be visible on Sheet1 while all the other pictures with a
name of the form MyPicnnn will be invisible. The visible picture is
also copied and pasted into exactly the same position on all the other
sheets after the copied MyPicnnn from the previous Sheet1 A1 value has
been deleted (deleted by the standard procedure)

If you want to try it out on a copy of your workbook...
1. Copy the following code
2. Right click the Sheet1 tab then select "View Code" from the Popup
menu
3. Paste the code into the Sheet1 code module (Both can go there)


Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'$A$1 is the address of the cell whose value determines
'which picture is visible. Change to suit your needs.
'Error will occur if $s omitted
Application.ScreenUpdating = False
Dim NewPicHeight As Single
Dim NewPicWidth As Single
Dim NewPicLeft As Single
Dim NewPicTop As Single
Dim NewPicName As String
DeleteOldPic
Dim ncPics As New Collection
Dim Shp As Shape
Dim Sht As Worksheet
For Each Shp In Me.Shapes
If Left(Shp.Name, 5) = "MyPic" Then
ncPics.Add Item:=Shp
End If
Next Shp
For Each Shp In ncPics
If Right(Shp.Name, Len(Target.Value)) _
= CStr(Target.Value) Then
Shp.Visible = True
NewPicHeight = Shp.Height
NewPicWidth = Shp.Width
NewPicLeft = Shp.Left
NewPicTop = Shp.Top
Shp.Copy
NewPicName = Shp.Name
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
With Sht
.Paste
.Activate
.Range("A1").Select
End With
Me.Activate
End If
Next Sht
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
With Sht.Shapes(NewPicName)
.Height = NewPicHeight
.Width = NewPicWidth
.Top = NewPicTop
.Left = NewPicLeft
.Name = "OldPic"
End With
End If
Next Sht
Else: Shp.Visible = False
End If
Next Shp
End If
End Sub



Public Sub DeleteOldPic()
Dim Sht As Worksheet
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Worksheets(1).Name Then
On Error Resume Next
Sht.Shapes("OldPic").Delete
End If
Next Sht
End Sub

Hope this helps you with your canoe.

Ken Johnson

[Ken Johnson]

Hi Bruce,

I reread your original post only to discover I've basically got things
face about apex.

I just had to change it a little so that you can use any sheet as the
sheet with all the pictures (only one will be visible though once the
code has been activated) and the cell that has the picture controlling
value.
Just paste the following code into Sheet5's code module. You get to
that code module by right clicking the Sheet5 sheet tab then selecting
"View Code" from the popup menu.

Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'$A$1 is the address of the cell whose value determines
'which picture is visible. Change to suit your needs.
'Error will occur if $s omitted
Application.ScreenUpdating = False
Dim NewPicHeight As Single
Dim NewPicWidth As Single
Dim NewPicLeft As Single
Dim NewPicTop As Single
Dim NewPicName As String
Dim SheetWithAllPics As String
SheetWithAllPics = Me.Name
DeleteOldPic (SheetWithAllPics)
Dim ncPics As New Collection
Dim shp As Shape
Dim Sht As Worksheet
For Each shp In Me.Shapes
If Left(shp.Name, 5) = "MyPic" Then
ncPics.Add Item:=shp
End If
Next shp
For Each shp In ncPics
If Right(shp.Name, Len(Target.Value)) _
= CStr(Target.Value) Then
shp.Visible = True
NewPicHeight = shp.Height
NewPicWidth = shp.Width
NewPicLeft = shp.Left
NewPicTop = shp.Top
shp.Copy
NewPicName = shp.Name
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
With Sht
.Paste
.Activate
.Range("A1").Select
End With
Me.Activate
End If
Next Sht
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
With Sht.Shapes(NewPicName)
.Height = NewPicHeight
.Width = NewPicWidth
.Top = NewPicTop
.Left = NewPicLeft
.Name = "OldPic"
End With
End If
Next Sht
Else: shp.Visible = False
End If
Next shp
End If
End Sub

Public Sub DeleteOldPic(SkipSheet As String)
Dim Sht As Worksheet
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> SkipSheet Then
On Error Resume Next
Sht.Shapes("OldPic").Delete
End If
Next Sht
End Sub

Ken Johnson

[Ken Johnson]

Hi Bruce,

You may at some stage want all of the pictures on sheet5 to be visible
so that you can make any adjustments. When that time arrives just run
the following macro from the sheet with all the pics.

Public Sub showall()
Dim shp As Shape
For Each shp In ActiveSheet.Shapes
shp.Visible = True
Next shp
End Sub

Just copy/paste the code into a standard module by going Copy the
code>activate workbook>Alt + F11 to get to VBA
Editor>Insert>Module>Paste the code into the new module.

Ken Johnson

[brucemc]

Thanks Ken-

I really thought I was pushing the moderator's tolerance envelope by keeping my post alive with my little refresher comments, and kind of expected to be scolded at this point, but very glad to see I happened to catch you at just the right time. Thank-you, and thank-you to the mod!

Hope to return the favor someday,
-Bruce

[Ken Johnson]

Hi Bruce,

One thing my code hasn't allowed for is the need for different picture
dimensions on one or more of the other sheets (Sheets 1 to 4).
I've added four new variables...

HeightFactor
WidthFactor
LeftAdjust
TopAdjust

and a Select case that depends on the names of sheets requiring that
the MyPic be of different size and/or position.
This part of the code will have to be edited to suit your needs.
You only have to change the sheet names at each Case line and tweak the
Factors and Adjusts values to get the MyPics correctly sized and
positioned. If only one sheet, say Sheet3, needs MyPics to be altered
this way then you only need two blocks of Case code, Case "Sheet3" and
Case Else. Extra blocks will have to be included depending on how many
sheets require MyPic changes.

At the moment the code is set up for each MyPic to be 10% smaller and
36 points further down the sheet on a sheet that has been renamed "My
Sheet" (originally named Sheet1) and 20% larger and 48 points closer to
the left side of Sheet3 (not renamed), and it looks like...


For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
Select Case Sht.Name
Case "My Sheet"
HeightFactor = 0.9
WidthFactor = 0.9
LeftAdjust = 0
TopAdjust = 36
Case "Sheet3"
HeightFactor = 1.2
WidthFactor = 1.2
LeftAdjust = -48
TopAdjust = 0
Case Else
HeightFactor = 1
WidthFactor = 1
LeftAdjust = 0
TopAdjust = 0
End Select
With Sht.Shapes(NewPicName)
.Height = NewPicHeight * HeightFactor
.Width = NewPicWidth * WidthFactor
.Top = NewPicTop + TopAdjust
.Left = NewPicLeft + LeftAdjust
.Name = "OldPic"
End With
End If
Next Sht

I hope this all makes sense.

Here is the complete code including the above changes plus some code
comments...

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = "$A$1" Then
'$A$1 is the address of the cell whose value determines
'which picture is visible. Change to suit your needs.
'Error will occur if $s omitted
Application.ScreenUpdating = False
Dim NewPicHeight As Single
Dim NewPicWidth As Single
Dim NewPicLeft As Single
Dim NewPicTop As Single
Dim HeightFactor As Single
Dim WidthFactor As Single
Dim LeftAdjust As Single
Dim TopAdjust As Single
Dim NewPicName As String
Dim SheetWithAllPics As String
SheetWithAllPics = Me.Name
DeleteOldPic (SheetWithAllPics)
Dim ncPics As New Collection
Dim shp As Shape
Dim Sht As Worksheet
For Each shp In Me.Shapes
If Left(shp.Name, 5) = "MyPic" Then
ncPics.Add Item:=shp
End If
Next shp
For Each shp In ncPics
If Right(shp.Name, Len(Target.Value)) _
= CStr(Target.Value) Then
shp.Visible = True
NewPicHeight = shp.Height
NewPicWidth = shp.Width
NewPicLeft = shp.Left
NewPicTop = shp.Top
shp.Copy
NewPicName = shp.Name
'Paste MyPics onto other worksheets
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
With Sht
.Paste
.Activate
.Range("A1").Select
End With
Me.Activate
End If
Next Sht
'Control MyPic's dimensions and positions.
'Factors = 1 and Adjusts = 0 for no change.
'Alter their values to suit your needs.
'MyPic will be distorted if Factors are
'not equal.
'Edit strings at each Case line to name
'of a sheet on which MyPic needs change in
'size and/or position.
'Tweak the Factor and Adjust(pts) values
For Each Sht In ActiveWorkbook.Worksheets
If Sht.Name <> Me.Name Then
Select Case Sht.Name
Case "My Sheet"
HeightFactor = 0.9 'height reduced 10%
WidthFactor = 0.9 'width reduced 10%
LeftAdjust = 0
TopAdjust = 36 '36 pts lower
Case "Sheet3"
HeightFactor = 1.2 '20% taller
WidthFactor = 1.2 '20% wider
LeftAdjust = -48 '48 pts to left
TopAdjust = 0
Case Else
HeightFactor = 1
WidthFactor = 1
LeftAdjust = 0
TopAdjust = 0
End Select
With Sht.Shapes(NewPicName)
.Height = NewPicHeight * HeightFactor
.Width = NewPicWidth * WidthFactor
.Top = NewPicTop + TopAdjust
.Left = NewPicLeft + LeftAdjust
.Name = "OldPic"
End With
End If
Next Sht
Else: shp.Visible = False
End If
Next shp
End If
End Sub

Ken Johnson

[brucemc]

Thank-you for all the thought you have put into this one! I've gone through the code and learned the use of creating my own collection - something I never did before. Funny, but I really thought that somehow we would be able to put a shape on sheets 1 through 4, put all the pictures on sheet 5, then simply address some sort of sheet "property" of each shape object on the first four sheets to point to the correct picture on sheet 5. Seemed so straight forward that I thought it had to exist, and that I simply had not yet learned the magical command sequence.

Anyway, thanks, again. I appreciate the solution you provided, but more, I enjoyed learning from the code you wrote. Does that make me a geek?

[Ken Johnson]

Hi Bruce,

Glad you found it useful.
The New Collections stuff is something I learnt just a couple of months
ago and I've found it indispensible when working with shapes. I imagine
there are heaps of other uses I don't yet know about.

Ken Johnson - Fellow Geek maybe:-)