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
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
