Picture in Cell of Active Sheet

[Sige]

Hi All,

I have a Picture (Picture 5 in Name Box) stored on a hidden sheet.

Is it possible to load this picture in Cell A1 on every active sheet.
Resizing it to the actual A1-Cell size of that active sheet?

Brgds Sige

 

[Norman Jones]

Hi Sige,

Try:
'===================>>
Private Sub Workbook_SheetActivate(ByVal Sh As Object)
Dim pic As Picture
Dim WS As Worksheet
Set WS = Sheets("YOUR HIDDEN SHEET NAME")

If Sh.Name <> WS.Name Then
On Error Resume Next
Sh.Pictures.Delete
On Error GoTo 0

Set pic = WS.Pictures("Picture 5")

With pic
.CopyPicture
Sh.Paste Destination:=Sh.Range("A1")

.Top = Range("A1").Top
.Left = Range("A1").Left
.Height = Range("A1").EntireRow.Height
.Width = Sh.Range("A1").EntireColumn.Width

End With
End If
End Sub
'<<===================

Paste this code into the Workbook's ThisWorkbook module, not into a standard
module,

 

[Sige]

Beautiful Norman!

Can the picture resize as well? If cell-size (A1) changes the picture
changes with ...?

Brgds Sige

 

[Norman Jones]

Hi Sige,

Can the picture resize as well? If cell-size (A1) changes the picture
changes with ...?

In a standard module, paste the following sub:

'===================>>
Sub RunOnce()
Dim sh As Worksheet

For Each sh In ActiveWorkbook.Worksheets
If sh.Name <> "YOUR HIDDEN SHEET NAME" Then
On Error Resume Next
sh.Pictures.Delete
On Error GoTo 0
End If
Next sh

End Sub
'<<===================

Please run this sub *once*, Change "YOUR HIDDEN SHEET NAME" to the
requisite sheet name.

Then replace your existing Workbook_SheetActivate code with this revised
version:

'===================>>
Private Sub Workbook_SheetActivate(ByVal sh As Object)
Dim pic As Picture
Dim WS As Worksheet
Dim rng As Range
Set WS = Sheets("YOUR HIDDEN SHEET NAME")
Set rng = sh.Range("A1")

If sh.Name <> WS.Name Then
If sh.Pictures.Count = 0 Then
Set pic = WS.Pictures("Picture 5")
pic.CopyPicture
sh.Paste Destination:=rng

With sh.Pictures(1)
.Top = rng.Top
.Left = rng.Left
.Height = rng.Rows(1).RowHeight
.Width = rng.EntireColumn.Width
.Placement = xlMoveAndSize
End With
End If
End If
End Sub
'<<===================

 

[Sige]

Fantastic! )))

I wished my Outline-problem would be the same ... hint, hint ;o)
Cheers Sige