VBA - Shape background change to image

ExcelLee

New Member
Joined
Mar 4, 2021
Messages
7
Office Version
  1. 2019
  2. 2016
  3. 2013
Platform
  1. Windows
  2. MacOS
Hi all,

First time poster but long time VBA/Excel user.

I have a bit of a conundrum where by I have a report which utilises images which every time have to be inserted and resized manually.

To avoid this I decided to insert rectangles where the images are to go. I then tried to record a macro/write a macro to do the following however I am yet to have any success what so ever.

Workflow.
Select rectangle...
Shape Format...
Shape fill...
Choose image (note I do not want to use a file path here I want to make the file explorer window come up and the user select anything from their directory)
Insert image...
Has a black border...
End macro.

Thanks in advance all.

Lee
 

Excel Facts

Create a Pivot Table on a Map
If your data has zip codes, postal codes, or city names, select the data and use Insert, 3D Map. (Found to right of chart icons).
How about this? The user clicks in a range and is prompted to choose an image.

You can change the range of A1 to whatever range of cells you want to the macro to fire on.

VBA Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim FSel As Object
Dim FileStr As String
Dim ImageLocationCell As Range

    If Not Intersect(Range("A1"), Target) Is Nothing Then
        Set FSel = Application.FileDialog(msoFileDialogFilePicker)
        Set ImageLocationCell = Target
        With FSel
            .Show
        End With
        FileStr = FSel.SelectedItems(1)
        InsertPic FileStr, ImageLocationCell
    End If
End Sub

Private Sub InsertPic(filePath As String, ByVal insertCell As Range)
    Dim xlShapes As Shapes
    Dim xlPic As Shape
    Dim xlWorksheet As Worksheet

    If IsEmpty(filePath) Or Len(Dir(filePath)) = 0 Then
        MsgBox ("File Path invalid")
        Exit Sub
    End If

    Set xlWorksheet = ActiveSheet
   
    Set xlPic = xlWorksheet.Shapes.AddPicture(filePath, msoFalse, msoCTrue, insertCell.Left, insertCell.Top, insertCell.Width, insertCell.Height)
    With insertCell.Borders
        .LineStyle = xlContinuous
        .Weight = xlMedium
        .Color = vbBlack
    End With
    xlPic.Placement = xlMoveAndSize
    xlPic.LockAspectRatio = msoCTrue
End Sub
 
Upvote 0
Hi Robbo,

Thank you for this.

I like the way this operates however I have one issue.

I have employees that are operating a Mac OS and therefore when they run this macro it returns the attached. Is there a workaround to allow for both operating systems or would this only work for windows?

The debugger says its an error on .show

Thanks for your efforts so far.

Lee
 

Attachments

  • Screenshot 2021-03-05 at 08.58.43.png
    Screenshot 2021-03-05 at 08.58.43.png
    23.2 KB · Views: 14
Upvote 0
Can anyone assist with a different option to allow for both MAC and Windows users to work in harmony?
 
Upvote 0

Forum statistics

Threads
1,213,539
Messages
6,114,221
Members
448,554
Latest member
Gleisner2

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top