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

Format cells as date
Select range and press Ctrl+Shift+3 to format cells as date. (Shift 3 is the # sign which sort of looks like a small calendar).

Watch MrExcel Video

Forum statistics

Threads
1,118,857
Messages
5,574,679
Members
412,612
Latest member
Shotokan
Top