Adding logo to multiple worksheets

Craig1

Active Member
Joined
Jun 11, 2009
Messages
320
Hi All,
I am using the code below to add logo's to multiple worksheets. It works great until I send the workbooks to my colleagues. The logo isn't visible for them, I believe it's because it is creating a link to the picture in my own personal drive, I want to embed the logo, could I change the code to embed? When go to my colleagues PC it shows the error "The linked image cannot be displayed" but when I check for links there isn't any, so I think the easiest way will be to modify the code.
Sub AddPicMain()

Dim myPicture As Variant
Dim p As Object
Dim Factor As Single
myPicture = Application.GetOpenFilename _
("Pictures (*.gif; *.cgm; *.jpg; *.bmp; *.tif),*.gif; *.cgm; *.jpg; *.bmp; *.tif", _
, "Select Picture to Import")
If myPicture = False Then Exit Sub
For Each Page In Sheets
Page.Activate
Range("A1").Select
Set p = ActiveSheet.Pictures.Insert(myPicture)
'Width and Height are in points (1/72 inch)
p.ShapeRange.LockAspectRatio = msoTrue
Hfactor = 1.5 / (p.Height / 72)
Wfactor = 7 / (p.Width / 72)
If Hfactor < Wfactor Then
Factor = Hfactor
Else
Factor = Wfactor
End If
p.Width = p.Width * Factor
p.Height = p.Height * Factor

Next
End Sub

Thanks in advance Craig.
 

Some videos you may like

Excel Facts

Quick Sum
Select a range of cells. The total appears in bottom right of Excel screen. Right-click total to add Max, Min, Count, Average.

Craig1

Active Member
Joined
Jun 11, 2009
Messages
320
Thanks for the reply Yongle,
I'm struggling a little to get this method to do the exact same thing.

Craig.
 

Yongle

Well-known Member
Joined
Mar 11, 2015
Messages
6,872
Office Version
  1. 365
Platform
  1. Windows
This should get you started
- I have added declarations for ALL variables
- it does help when your code does not work as planned etc

Code:
Sub AddPicMain()

    Dim myPicture As Variant, [COLOR=#008080]Page As Variant, Hfactor As Double, Wfactor As Double,[/COLOR][COLOR=#008080]p As Shape[/COLOR]
    Dim Factor As Single
        myPicture = Application.GetOpenFilename _
            ("Pictures (*.gif; *.cgm; *.jpg; *.bmp; *.tif),*.gif; *.cgm; *.jpg; *.bmp; *.tif", _
                , "Select Picture to Import")
    If myPicture = False Then Exit Sub
    For Each Page In Sheets
        Page.Activate
        Range("A1").Select
        Set p = ActiveSheet.Shapes.AddPicture(myPicture, True, True, Range("A1").Left, Range("A1").Top, -1, -1)
        p.LockAspectRatio = msoTrue
        Hfactor = 1.5 / (p.Height / 72)
        Wfactor = 7 / (p.Width / 72)
        If Hfactor < Wfactor Then
            Factor = Hfactor
        Else
           Factor = Wfactor
        End If
        p.Width = p.Width * Factor
        p.Height = p.Height * Factor
    Next
End Sub
 

Craig1

Active Member
Joined
Jun 11, 2009
Messages
320
Yongle, Thanks for that, it works great.
Does exactly what it says on the tin.

Thanks Again.

Craig.
 

Watch MrExcel Video

Forum statistics

Threads
1,118,414
Messages
5,571,970
Members
412,429
Latest member
brahmaiah
Top