Inserting Image on several worksheets in same workbook

[mykal66]

Hi

I need to be able to insert an image (user selected) into several ranges (same page or separate worksheets) within a workbook without having to select the image each time.

The attached workbook uses code I've found does exactly what i need in that the user selects a specific image which is then resized and pasted into a gi8ven range. What i cannot do is then get the same image to resize and fit within a different range (either on the same page or another worksheet).

As you can see i can get it to work if i create all separate modules and once the first image is inserted / resized it calls the next module which does the next resize /paste but each time the user needs to re-select the image.

Not the best at VBA but can usually scrape by but i know this is a long winded messy way to do what i need (and not user friendly either) so if anyone can advise how i can clean this up to work with just one user selection that would be great.

Essentially the image is a company logo inserted in several places over a 10 worksheet book (all of which will be differing sizes) -hence the need to resize within a set range.

Thanks

Mykal

Book2.xlsm

[mykal66]

Hi again.

I'm still plodding on with this and got closer - see code below.

I can now get it to paste the same image in each page, same area. I juts need to someone amend the range when i change to another worksheet

Mykal

[mdmackillop]

Sub TestInsertPictureInRangeCoverDoc1()
    Dim shArr, rArr
    shArr = Array("Doc1", "Doc2", "Doc3")
    rArr = Array("A2:Z3", "B2:M3", "F2:W3")
    InsertPictureInRange Application.GetOpenFilename(), shArr, rArr
End Sub


Sub InsertPictureInRange(PictureFileName As String, Shts As Variant, Rng As Variant)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
    
    For i = 0 To UBound(Shts)
    Set sh = Sheets(Shts(i))
    ' import picture
    Set p = sh.Pictures.Insert(PictureFileName)
    ' determine positions
    With sh.Range(Rng(i))
        t = .Top
        l = .Left
        w = .Offset(0, .Columns.Count).Left - .Left
        h = .Offset(.Rows.Count, 0).Top - .Top
    End With
    ' position picture
    With p
         If .Width > w Then .Width = w
         If .Height > h Then .Height = h
        .Top = t + (h - .Height) / 2
        .Left = l + (w - .Width) / 2
    End With
    Set p = Nothing
    Next i
End Sub

[p45cal]

In the attached click the only button there is.
The code:

Sub blah()
PictureFileAndPath$ = Application.GetOpenFilename()
InsertPictureInRange PictureFileAndPath, Sheets("Cover").Range("D6:H13")
InsertPictureInRange PictureFileAndPath, Sheets("Doc 2").Range("D7:H14")
InsertPictureInRange PictureFileAndPath, Sheets("Doc 2").Range("B21:E28")
'add as many lines as you want the same picture inserted
End Sub

Sub InsertPictureInRange(PictureFileName As String, TargetCells As Range)
' inserts a picture and resizes it to fit the TargetCells range
Dim p As Object, t As Double, l As Double, w As Double, h As Double
If TypeName(TargetCells.Parent) <> "Worksheet" Then Exit Sub
'If Dir(PictureFileName) = "" Then Exit Sub
' determine positions
With TargetCells
  t = .Top
  l = .Left
  w = .Offset(0, .Columns.Count).Left - l
  h = .Offset(.Rows.Count, 0).Top - t
End With
' import picture
Set p = TargetCells.Parent.Pictures.Insert(PictureFileName)  'this line will insert a linked picture.
'Set p = TargetCells.Parent.Shapes.AddPicture(PictureFileName, msoFalse, msoTrue, l, t, -1, -1)'this line will insert a picture without a link and save it with the file.
' position picture
With p
  If .Width > w Then .Width = w
  If .Height > h Then .Height = h
  .Top = t + (h - .Height) / 2
  .Left = l + (w - .Width) / 2
End With
Set p = Nothing
End Sub

The calling code attached to the button:

Private Sub CommandButton1_Click()
blah
End Sub

Note that the Pictures.Insert you use links to the file; if you send the workbook to someone else without the same file structure/file you'll get no logo. In the code, there's a commented out Set p = line to replace yours which will save the picture with the file and there'll be no link.

[mykal66]

Hi p45cal.

Thank you very much for adapting the code I'd found and pointing out that i'd lose the logo once i sent the file out. I will give this a go tomorrow when back in work and let you know how i got on.

Thanks again for the quick come back and help, very much appreciated.

Mykal

[mykal66]

Hi mdmackillop

Again, thank you for your help on this one. I've spent hours messing around to make a colleagues life easier (i won't even be using the doc) and got completely stuck so will try this and other responses when i'm back in work and advise how things went.

Big thank you

Mykal

[mykal66]

Hi.

Just wanted to say a big thank you to you guys who responded to my request yesterday and let you know i now have the insert working across all docs which will have my colleague dancing around the office later.

Thank you so much. I've asked for help a few times on her when i get really stuck and always get a response and wanted to say how much i appreciate it.

Thanks again

Mykal

[mdmackillop]

Happy to help
Regards
MD