User Form for view, inserting or changing a photo in a cell

[bisel]

Hello All,

I am a novice at writing efficient VBA code and hoping someone might be able to help me.

I have a workbook and would like to use the Excel capability to insert an image into a cell by having the user select an image located on their computer's hard drive somewhere. I like the idea of inserting an image into a cell because of the capability to retain sort order and filtering.

My concept is that the user would click to select a cell on the sheet and then give them the option to edit the image associated with that cell. If the user selects that option to edit the image, then have a user form open. Probably call the user form "Image Editor" or something like that. When the form initializes, I want the form to look like something like this ...

The User Form will initialize and show a preview of the current image associated with the cell that the user selects. The image will be in the cell not overlayed over the cell. Of course, if there is no image in the cell, merely show a blank. I then would think of having two control buttons to remove or replace the current image. My thought is that if there is no image in the cell, then the replace button would merely add one from a folder that the user would select. Lastly, the close the button would merely close the user form.

I know how to create simple user forms and understand the concept of initialize and activate events. Closing the form is no problem for me. What I need assistance with is how to create the VBA code so that when the user selects the component on the sheet, the form would initialize and show the preview of the currently associated image (if there is one).

Has anyone done anything like this? Can you point me in the right direction?

Thanks,

Steve

 

[Micron]

Family, although I don't see how that matters. Given all the bugs that M$ has introduced in Access updates, I turned off updates for Word, Excel and Access one or two years ago.

 

[Artik]

That would explain why in your case you can't insert an image into the cell. Thanks.

Artik

 

[Artik]

NdNoviceHlp, especially for you
Below is the full code that mimics the InsertPictureInCell method from 365. For all versions of Excel.

Option Explicit

'name of the column of the sheet with the pictures
Const ColName As String = "B"
'number of the first row of data
Const FirstRow As Long = 2


Sub InsertPictures()
'bulk insertion of pictures into a sheet
    Dim wks As Worksheet
    Dim Folder As String
    Dim i As Long
    Dim vArry As Variant

    Set wks = ActiveSheet
    Folder = "D:\Test3\"
    vArry = Split("Pic_1.jpg,Pic_2.jpg,Pic_3.jpg,Pic_4.jpg,Pic_5.jpg,Pic_6.jpg,Pic_7.jpg,Pic_8.jpg", ",")

    For i = 0 To UBound(vArry)
        Call InsertPicture(wks.Range(ColName & CStr(FirstRow)).Offset(i), Folder & vArry(i))
    Next i

End Sub

'CAUTION
'Do not insert rows into the data range.
'New data should be added at the end of the range.


Sub InsertPicture(Rng As Range, PicPath As String)
'inserting a single picture
'Rng - a reference to the cell into which the picture should be inserted
'PicPath - full path to the picture file

    Dim Pic As Picture
    Dim strCol As String

    'cell address next to
    strCol = Rng.Offset(, 1).Address(, 0)

    'insert the picture into the sheet (generally into the active cell, not the Rng cell)
    Set Pic = Rng.Parent.Pictures.Insert(PicPath)

    With Pic
        'unique image name
        .Name = "Pic_" & strCol
        'block the aspect ratio
        .ShapeRange.LockAspectRatio = msoTrue
        'Move and resize with cells
        .Placement = xlMoveAndSize
        'change the location of the picture and shrink it to the size of the cell (keeping the aspect ratio)
        Call RepositionPicture(Pic, Rng.Cells(1))
        'assign a macro to the picture
        .OnAction = "TogglePicSize"
        'into the cell where the picture is, insert the formula
        '- a reference to the cell next to it(the same address as in the strCol variable)
        Rng.Formula = "=" & strCol
        'hide values in a cell
        Rng.NumberFormat = ";;;"
    End With

End Sub


Sub RepositionPicture(Pic As Picture, Cell As Range)
'move the picture to the correct cell and adjust the size of the picture to the size of the cell
    With Cell
        Pic.Top = .Top + 1 * 0.75
        Pic.Left = .Left + 1 * 0.75
        Pic.Height = .Height - 2 * 0.75

        If Pic.Height > .Height Then
            Pic.Height = .Height - 2 * 0.75
        End If
        If Pic.Width > .Width Then
            Pic.Width = .Width - 2 * 0.75
        End If
    End With

End Sub


Sub TogglePicSize()
'toggle the size of the clicked image
    Dim Pic As Picture
    Dim Rng As Range
    Dim ColTmp As Range

    'create a reference to the clicked picture
    Set Pic = ActiveSheet.Pictures(Application.Caller)
    'create a reference to the cell where the image should be
    Set Rng = Range(Split(Pic.Name, "_")(1)).Offset(, -1)

    'redundant code, you can remove this line because the aspect ratio was blocked
    ' when inserting the image into the sheet
    Pic.ShapeRange.LockAspectRatio = msoTrue

    If Pic.Height < Rng.Height Then
        'if the picture is small then enlarge it to the original dimensions
        Pic.ShapeRange.ScaleHeight 1, msoTrue
        'bring the picture to the foreground
        Pic.ShapeRange.ZOrder msoBringToFront
    Else
        'The picture is larger than the cell, so reduce it to fit in the cell
        'by the way, corrects the position of the picture if it was accidentally moved earlier

        'A reference to the range in which the images are, e.g. B2:B9
        Set ColTmp = ActiveSheet.Range(ColName & CStr(FirstRow), ActiveSheet.Cells(Rows.Count, ColName).End(xlUp))

        'search the cells of the range to determine which cell the picture should be in,
        'for this you needed to assign an address to the name of the picture and a formula referring to the cell next to it
        For Each Rng In ColTmp.Cells
            'from the name Pic_C$3 extract only “C$3”, from the formula: “=C$3” take only the address
            'if both values are the same, we know which cell the picture should be in
            If Split(Pic.Name, "_")(1) = Mid(Rng.Formula, 2) Then
                Exit For
            End If
        Next Rng

        'make the picture smaller and possibly improve its location
        Call RepositionPicture(Pic, Rng)
    End If
End Sub

Artik

 

[NdNoviceHlp]

Artic it works great! Clicking on the image that's INSERTED IN THE CELL displays the full picture. I'm not sure if the pic is supposed to fit the cell? It doesn't for me but it doesn't really matter. I noticed that this following bit of code would be helpful to avoid inserting pictures on top of pictures when you run the routine more than once...

Sub InsertPicture(Rng As Range, PicPath As String)
'inserting a single picture
'Rng - a reference to the cell into which the picture should be inserted
'PicPath - full path to the picture file
    Dim Pic As Picture
    Dim strCol As String
    
    'remove existing pic from range
    Dim sh As Shape
    For Each sh In ActiveSheet.Shapes
    If sh.TopLeftCell.Address = Rng.Cells(1).Address Then
    sh.Delete
    Exit For
    End If
    Next
'etc...

With a bit of persistence seems most things are possible with VBA. Nicely done. Thanks for posting your solution. Dave

 

[Artik]

I'm not sure if the pic is supposed to fit the cell? It doesn't for me

I don't know if we understand each other well. The code is supposed to insert the image within the cell while maintaining the original aspect ratio. The cell doesn't have to be completely filled with the image, because in most cases this would destroy the preservation of the proportions. But if, in fact, the image goes outside the cell (when it should be small), then the RepositionPicture procedure should be traced in step mode (F8 key). In particular, check what happens when the conditions If Pic.Height... and If Pic.Width... are executed. I don't rule out that I've missed something. But on my test images with different sizes and aspect ratios, the code works flawlessly. Let me know if you detect a problem.

... but it doesn't really matter

It matters! I didn't sit on the solution for it to not work now.

I noticed that this following bit of code would be helpful to avoid inserting pictures on top of pictures when you run the routine more than once...

Yes, this can be a good functionality. It all depends on your needs. But keep in mind that this piece of code will cause a slight delay in performance due to the loop looking for an picture. I would even be tempted to add cleaning the contents of the cell Rng.Value = Empty.

Let us know what went wrong.

Artik

 

[NdNoviceHlp]

My misunderstanding. The image does fit withing the cell and it does maintain it's original aspect ratio. The "Rng.Value = Empty" doesn't seem to clear the previous pics at the least the way I trialed it. As you mentioned, it's dependent upon your needs as to whether you include code to remove any previous pics. Thanks again for your efforts. Dave

 

[Artik]

Rng.Value = Empty just to delete the formula. sh.Delete also needed.

Artik

 

[Artik]

After a while.
You can also do without the loop.

(...)
    Dim Pic As Picture
    Dim strCol As String

    'cell address next to
    strCol = Rng.Offset(, 1).Address(, 0)
    
    'remove existing pic from range
    'On Error Resume Next
    With Rng
        .Parent.Pictures("Pic_" & strCol).Delete
        .Value = Empty
    End With
    On Error GoTo 0

    'insert the picture into the sheet (generally into the active cell, not the Rng cell)
    Set Pic = Rng.Parent.Pictures.Insert(PicPath)
(...)

Artik