Adding Logos to Workbook in Specific Locations

[michele227]

Hi everyone,

I have a workbook with multiple sheets that require the same logo to be added (in certain sheets/cells listed below).
These are then changes by project - requiring a deletelogo macro as well.

I have the following code below that I am trying to adapt with no luck.
Also, I would like it to add the image (not the link) of the photo.

Thank you so much in advance
I am super new and appreciate all the help!

Request:
I'd like it to align with the edge of the selected cell.
It pastes like this:

But I would like to resize and crop it to look more like this (align with edge of H1):
Not sure if there is a way to allow me to fix one image and have the rest apply the same size or the same image?

These are the Sheets and cells within the sheets that I need it to add the Logos to:

Sheets("Log").Range("G1").Select
Sheets("Notes S").Range("J1").Select
Sheets("Notes B").Range("J1").Select
Sheets("Notes L").Range("J1").Select
Sheets("Notes L").Range("J59").Select
Sheets("Conditions").Range("G1").Select
Sheets("Schedule").Range("H1").Select
Sheets("Form").Range("H1").Select
Sheets("Letter").Range("H1").Select
Sheets("Information").Range("H1").Select
Sheets("Text").Range("J1").Select
Sheets("Question").Range("J1").Select
Sheets("Sample").Range("J1").Select
Sheets("Align").Range("J1").Select
Sheets("Help").Range("J1").Select
Sheets("Example").Range("J1").Select
Sheets("Main").Range("J1").Select

This is the code I found:

Sub addLogo()

' Macro to automatically add the same project logo to each applicable sheet.

Dim myPicture As Variant
Dim p As Object

ChDir Sheets("Schedule").Range("O17").Value
myPicture = Application.GetOpenFilename("Pictures(*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif),*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif", , "Select Logo to Insert")

If myPicture = False Then Exit Sub

For Each Sheet In Sheets
Sheet.Activate
On Error Resume Next
Call deleteLogo
Range("G1").Select
Set p = ActiveSheet.Pictures.Insert(myPicture)
Next

End Sub

I also have the code to delete the existing logo and replace it, but - it deletes all the other images in the workbook - which isn't good.

Sub deleteLogo()

' Macro to delete all added Logos.

Dim myObj
Dim Picture

Set myObj = Range("G1").Select.DrawingObjects

For Each Picture In myObj
If Left(Picture.Name, 7) = "Picture" Then
Picture.Select
Picture.Delete
End If
Next

End Sub

 

[John_w]

Try these macros which add and delete the logos. You'll have to add all your sheet names and cells to the sheetCells array because I've only done it for the first 4.

Public Sub Add_Logo_On_Sheets()

    Dim sheetCells As Variant, sheetCell As Variant
    Dim logoFile As Variant
    Dim p As Long, sheetName As String
    Dim rightAlignCell As Range
    Dim picShape As Shape
   
    sheetCells = Array("Log!G1", "Notes S!J1", "Notes B!J1", "Notes L!J1")
   
    logoFile = Application.GetOpenFilename("Pictures (*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif),*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif", , "Select Logo to Insert")
    If logoFile = False Then Exit Sub
   
    For Each sheetCell In sheetCells
   
        p = InStr(sheetCell, "!")
        sheetName = Left(sheetCell, p - 1)
        Set rightAlignCell = ThisWorkbook.Worksheets(sheetName).Range(Mid(sheetCell, p + 1)).Offset(, 1)
       
        With rightAlignCell
            Set picShape = ThisWorkbook.Worksheets(sheetName).Shapes.AddPicture(logoFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                Left:=.Left, _
                                Top:=.Top, _
                                Width:=-1, _
                                Height:=.Height)
        End With
       
        'Name shape and right-align on specified cell
       
        With picShape
            .Name = "Logo"
            .Left = rightAlignCell.Left - .Width
        End With
       
    Next
   
End Sub


Public Sub Delete_Logo_On_Sheets()

    Dim ws As Worksheet, i As Long
   
    For Each ws In ThisWorkbook.Worksheets
        With ws
            For i = .Shapes.Count To 1 Step -1
                If .Shapes(i).Name = "Logo" Then
                    .Shapes(i).Delete
                End If
            Next
        End With
    Next
   
End Sub

 

[michele227]

Hi John!

Wow! Thank you for the super fast response!
This is amazing and did everything I needed it to!

The image aligned nicely to the right, but it stretches it out like this:

Is it possible to have it resize to the size of row 1 (42 pixels I guess?) and 2 (28 pixels) combined?

Thanks so much!

 

[John_w]

The image aligned nicely to the right, but it stretches it out like this:

The code shouldn't stretch the image. The Width:=-1 should keep its original width.

Is it possible to have it resize to the size of row 1 (42 pixels I guess?) and 2 (28 pixels) combined?

Change Height:=.Height to Height:=.Height + .Offset(1).Height

 

[michele227]

The code shouldn't stretch the image. The Width:=-1 should keep its original width.


Change Height:=.Height to Height:=.Height + .Offset(1).Height

Thanks John!
I made that change but it still stretches it.
I tried editing the following to lock the ratio but it hasn't helped either, I probably didn't do it right.
Any other ideas?

With picShape
.Name = "Logo"
.LockAspectRatio = msoTrue
.Left = rightAlignCell.Left - .Width
End With

 

[John_w]

I can't reproduce the stretching behaviour. At which point is it stretching? On the Set picShape = line or the .Left = rightAlignCell.Left - .Width line? Step through the code by pressing the F8 key in the VBA editor.

You could try these changes, to insert the logo in its original size and then move its Left position and change its Height.

        With rightAlignCell
            Set picShape = ThisWorkbook.Worksheets(sheetName).Shapes.AddPicture(logoFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                Left:=.Left, _
                                Top:=.Top, _
                                Width:=-1, _
                                Height:=-1)
        End With
        
        'Name shape and right-align on specified cell
        
        With picShape
            .Name = "Logo"
            .LockAspectRatio = msoFalse
            .Left = rightAlignCell.Left - .Width
            .Height = rightAlignCell.Height + rightAlignCell.Offset(1).Height
        End With

 

[michele227]

I can't reproduce the stretching behaviour. At which point is it stretching? On the Set picShape = line or the .Left = rightAlignCell.Left - .Width line? Step through the code by pressing the F8 key in the VBA editor.

You could try these changes, to insert the logo in its original size and then move its Left position and change its Height.

        With rightAlignCell
            Set picShape = ThisWorkbook.Worksheets(sheetName).Shapes.AddPicture(logoFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
                                Left:=.Left, _
                                Top:=.Top, _
                                Width:=-1, _
                                Height:=-1)
        End With
       
        'Name shape and right-align on specified cell
       
        With picShape
            .Name = "Logo"
            .LockAspectRatio = msoFalse
            .Left = rightAlignCell.Left - .Width
            .Height = rightAlignCell.Height + rightAlignCell.Offset(1).Height
        End With

Hi John,

Thanks so much for not giving up on me!

I stepped into the macro, but it pastes quickly once it gets to the part where I select the file so I don't get to see where it stretches.

I tried modifying a few things just to see what the result would be, this is what I get:
The last example is closer to the look I want, except the placement and alignment isn't where it needs to be for some reason!

 

[John_w]

You should be able to step line by line. Set a breakpoint on the With rightAlignCell line to ensure it stops there.

What type of file is the logo - png, jpeg, bmp, etc?

 

[michele227]

You should be able to step line by line. Set a breakpoint on the With rightAlignCell line to ensure it stops there.

What type of file is the logo - png, jpeg, bmp, etc?

I had to google what a breakpoint is! But it worked!
It stretched when it got to the End With part, which from the beginner VBA videos I watched, I think that means the line right before was performed, which is this one:
.Height = rightAlignCell.Height + rightAlignCell.Offset(1).Height
End With
Next

The logo files I use are .png.

 

[michele227]

You should be able to step line by line. Set a breakpoint on the With rightAlignCell line to ensure it stops there.

What type of file is the logo - png, jpeg, bmp, etc?

Hi John!

I got it to work!!
Lots of trial and error.

I moved the .left portion to go below the .height part.
That seemed to fix the issue.

I want to give you a huge thanks for saving me hours of work per week with this macro.
Hope you have an amazing rest of the week!

Public Sub Add_Logn_Sheets()

Dim sheetCells As Variant, sheetCell As Variant
Dim logoFile As Variant
Dim p As Long, sheetName As String
Dim rightAlignCell As Range
Dim picShape As Shape

' Add list of sheets here. sheetCells = Array("Communication Log!G1")

ChDir Sheets("Payment Schedule").Range("O17").Value
logoFile = Application.GetOpenFilename("Pictures (*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif),*.png;*.jpg;*.jpeg;*.tif;*.bmp;*.gif", , "Select Logo to Insert")
If logoFile = False Then Exit Sub

For Each sheetCell In sheetCells

p = InStr(sheetCell, "!")
sheetName = Left(sheetCell, p - 1)
Set rightAlignCell = ThisWorkbook.Worksheets(sheetName).Range(Mid(sheetCell, p + 1)).Offset(, 1)

With rightAlignCell
Set picShape = ThisWorkbook.Worksheets(sheetName).Shapes.AddPicture(logoFile, LinkToFile:=msoFalse, SaveWithDocument:=msoTrue, _
Left:=.Left, _
Top:=.Top, _
Width:=-1, _
Height:=-1)
End With

' Name shape and right-align on specified cell

With picShape
.Name = "Logo"
.LockAspectRatio = msoTrue
.Height = rightAlignCell.Height + rightAlignCell.Offset(1).Height
.Left = rightAlignCell.Left - .Width
End With
Next
End Sub