Copy logo to selected sheets only

Llew123

New Member
Joined
Oct 20, 2014
Messages
7
Good day everyone,

I've copied and amended this vbscript from a page on the net, but can't get it to work the way I want it to. I need the user the be able to select the logo they want as it currently does, and then copy the logo to cell $B$2 for sheets 3, 4 and 5 only. I also has some code that enables the sheet to replace a previously loaded logo but this is not a critical functionality (only nice to have). The current code does copy the selected logo to the sheets, but to all, not just sheet 3, 4 and 5. Any help would be greatly appreciated. Below is the script I've used. By the way, I am no vbscript expert.

Sub AddLogo()

Dim myPicture As Variant
Dim p As Object
Dim Factor As Single
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.png; *.jpg; *.bmp; *.tif),*.gif; *.png; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If myPicture = False Then Exit Sub
For Each Page In Sheets
Page.Activate
'ActiveSheet.Unprotect Password:="elvis1"
'DELETE THE OLD PICTURES
On Error Resume Next
Dim ShapeObject As Shape

For Each ShapeObject In ActiveSheet.Shapes

' Uncomment the following line to get a prompt of every shape object type.
' Write down all the Types it shows you, and use trial-and-error to figure out what type any given picture is.
' KNOWN TYPES: Form Buttons are Type 12, Drop Down Boxes are Type 8, JPegs and GIfs are Type 13
' The Message Box will pop-up for every shape it encounters, which may be dozens, so keep clicking "OK" until it finishes the loop

'MsgBox ShapeObject.Type
Page.Range("$B$2").Select
If ShapeObject.Type = 13 Or ShapeObject.Type = 7 Then
Call ShapeObject.Delete
End If
Next

'FINISHED DELETING OLD PICTURES
Page.Range("$B$2").Select
Set p = ActiveSheet.Pictures.Insert(myPicture)
'Width and Height are in points (1/72 inch)
p.ShapeRange.LockAspectRatio = msoTrue
Hfactor = 5 / (p.Height / 55)
Wfactor = 5.69 / (p.Width / 55)
If Hfactor < Wfactor Then
Factor = Hfactor
Else
Factor = Wfactor
End If
p.Width = p.Width * Factor
p.Height = p.Height * Factor
' ActiveSheet.Protect Password:="elvis1"
Next
End Sub


Thanks again.

Llewellyn
 

Some videos you may like

Excel Facts

What is =ROMAN(40) in Excel?
The Roman numeral for 40 is XL. Bill "MrExcel" Jelen's 40th book was called MrExcel XL.

Watch MrExcel Video

Forum statistics

Threads
1,118,757
Messages
5,574,053
Members
412,565
Latest member
roberttaekim
Top