Code to open file explorer to insert and resizing picture on selected Cell?

Question

Hello, new to VBA.

I'm making a catalog with over 300 items and wanted to know is there a easy way to insert and resizing a pictures when I select a cell.

Answer 1

Also you will see that '.LockAspectRatio = False is commented out with the single quote and a comment after it that it is optional. The Aspect ratio is locked (or True) with the code below that has width and height both set to -1.

Set shpMyImg = Me.Shapes.AddPicture _

                    (Filename:=strPathAndPic, _

                    LinkToFile:=msoFalse, _

                    SaveWithDocument:=msoTrue, _

                    Left:=.Left, _

                    Top:=.Top, _

                    Width:=-1, _

                    Height:=-1)

Note that the space and underscore at the end of a line is a line break in an otherwise single line of code. I use it when there are lots of arguments (or parameters) in a line of code because it tabulates the arguments and makes it easy to read the code. 

When the aspect ratio is locked (or True), only the width or height can be set; not both. When one is set the other one automatically re-sets to keep the width and height ratio. If both are set then the last one set takes precedence and automatically resets the previous one.

In the following code Aspect ratio remains true due to the previous code the aspect ratio line is commented out therefore Height takes precedence because it is the last one set. The order of setting the left, top width and height does not matter in the following code.

    With shpMyImg

        '.LockAspectRatio = False   'Optional

        .Left = dblLeft

        .Top = dblTop

        .Width = dblWdth

        .Height = dblHt

Answer 2

This was highlight in red:

"Next line If locked then only Height or Width can be set. (Last set takes precedence)"

My apologies for that. I added that line after posting and it is actually a comment and should have a leading single quote so just insert the leading single quote at the start of the line (when you move the cursor off the line it will then become green)

Answer 3

Hello http://answers.microsoft.com/en-us/profile/9e137309-bb68-49d3-87db-7b9aab6ea694OssieMac,

Thank for the reply and instruction. On the third step, I replace the "C:C " to the file path where it suppose to go. Example: (( C:\Users\User\Desktop\Folder\Photos )) and paste the same path on step four.

When I run the code, I receive an Compile Error: Syntax Error.

This was highlight in red:

"Next line If locked then only Height or Width can be set. (Last set takes precedence)"

Answer 4

The code below requires you to double click the cell where the picture is to be inserted. The code resizes the picture to the same size as the cell but this can be changed if you desire.

Firstly the code brings up the file select dialog so that you can navigate to and select the required picture. After selecting the picture, it is inserted at the cell where you double click.

Please feel free to get back to me if you have any problems either with the editing or other problems.

To install the code.

1. Right click the worksheet tab and select View code to open the VBA editor.
2. Copy the code below and paste into the VBA editor
3. Edit the code where you see the comment in green to edit "C:C" to the required column for the pictures.
4. Also edit the initial path to commence the search for the required picture file and if your file type is not included in the Filter then edit that line also.
5. Close the VBA editor. (Cross at top most right corner of VBA editor)
6. Use "Save as" to Save the workbook as macro enabled.
7. Ensure that macros are enabled. See help for how to do this. (The option to "Disable all with notification" should be OK)
8. Now you should be able to double click the cell where the picture is required and then select the file from the file dialog.
9. Comments are bolded italics where editing required. (It will simply be standard green front when pasted into VBA editor.)

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)

    Dim fd As FileDialog

    Dim strPathAndPic As String

    Dim strDialogTitle

    Dim dblLeft As Double

    Dim dblTop As Double

    Dim dblWdth As Double

    Dim dblHt As Double

    Dim shpMyImg 'As Shape

    'Test if double click is in the required column

    'If intersect is nothing then not correct column

    'Edit "C:C" to required column for pictures.

    If Intersect(Target, Columns("C:C")) Is Nothing Then Exit Sub

    Cancel = True   'Cancels double click that normally invokes edit in cell mode

    strDialogTitle = "Select required picture file."

    Set fd = Application.FileDialog _

            (msoFileDialogFilePicker)

    With fd

       'Next line Edit path to your initial path to search for picture

        .InitialFileName = "C:\Users\User\Documents\Excel\Test Macros"

        .AllowMultiSelect = False

        .Filters.Clear

        .Filters.Add "Pictures", "*.jpg; *.bmp; *.tif", 1 'Edit and/or add file types

        .Title = strDialogTitle

        If .Show = False Then

          MsgBox "User cancelled." & vbLf & _

            "Processing terminated."

            Exit Sub

        End If

        strPathAndPic = .SelectedItems(1)

    End With

    With Target

        dblLeft = .Left

        dblTop = .Top

        dblWdth = .Width

        dblHt = .Height

        Set shpMyImg = Me.Shapes.AddPicture _

                    (Filename:=strPathAndPic, _

                    LinkToFile:=msoFalse, _

                    SaveWithDocument:=msoTrue, _

                    Left:=.Left, _

                    Top:=.Top, _

                    Width:=-1, _

                    Height:=-1)

    End With

    With shpMyImg

       'Next line If locked then only Height or Width can be set. (Last set takes precedence)

       ' .LockAspectRatio = False   'Optional True or False

        .Left = dblLeft

        .Top = dblTop

        .Width = dblWdth

        .Height = dblHt

        'Name the image so it can be referenced later in other subs

        .Name = "Pic_" & Target.Address(0, 0)   'Names the image with Pic and cell address

        .Placement = xlMoveAndSize  'Allow to move and size with the cell.

    End With

End Sub