Insert Photos, Resize, Keep Aspect Ratio into particular merged cell

[sadsack5000]

Hello all,

I've scoured the internet and pieced together some code to help in my task of developing an inspection report template. I know nothing about VBA so the below is probably totally wrong.

As part of the report im trying to create a photos page where the user clicks on a cell, the insert picture dialogue appears and once the photo is selected it is imported into the same cell and resized (keeping aspect ratio) to the extents of the cell. The photos template i have created contains eight boxes for photos made up from merged cells.

I have partially got it working by scraping around the internet / trial and error.

First i made this macro as a module in the VBA side

Sub InsertPictures()     
    Dim Pict As Variant
    Dim ImgFileFormat As String
    Dim rngPict As Range
    Dim lLoop As Long
     
    'ActiveSheet.Protect False, False, False, False, False
     'ImgFileFormat = "Image Files gif (*.gif),*.gif,(*.jpg), others, tif (*.tif),*.tif"
     
    Pict = Application.GetOpenFilename(ImgFileFormat, MultiSelect:=True)
    
     'Note you can load in any nearly file    format
    If Not IsArray(Pict) Then
        Debug.Print "No files selected."
        Exit Sub
    End If
          
    Application.ScreenUpdating = False
    For lLoop = LBound(Pict) To UBound(Pict)
    
        Set rngPict = Cells(lLoop, "A")
        
        With ActiveSheet.Pictures.Insert(Pict(lLoop))
            .Left = rngPict.Left
            .Top = rngPict.Top
            If .Width / .Height > rngPict.Width / rngPict.Height Then
                .Height = .Height * rngPict.Width / .Width
                .Top = .Top + (rngPict.Height - .Height) / 2
                .Width = rngPict.Width
            Else
                .Width = .Width * rngPict.Height / .Height
                .Left = .Left + (rngPict.Width - .Width) / 2
                .Height = rngPict.Height
            End If
        End With
        
    Next lLoop
    Application.ScreenUpdating = True
    
End Sub

Then i added this code into the "View code" section of the photos sheet which tells excel to run the above when any of my merged cells are double clicked:

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)    If Target.Cells(1).Address = "$B$3" Or Target.Cells(1).Address = "$S$3" Or Target.Cells(1).Address = "$B$15" Or Target.Cells(1).Address = "$S$15" Or Target.Cells(1).Address = "$B$27" Or Target.Cells(1).Address = "$S$27" Or Target.Cells(1).Address = "$B$39" Or Target.Cells(1).Address = "$S$39" Then
        Cancel = True
        Call InsertPictures
    End If
End Sub

However every time i double click one of my photo "frames" the picture is inserted into cell A1 which is incorrect.

Where am i going wrong?

Thanks in advance

 

[sadsack5000]

EDIT:

It appears as though landscape photos get inserted into A1 whilst portrait photos seem even weirder! they get inserted somewhere around AH1 and have lost their aspect ratio (they are now more like a horizontal rectangle)

 

[sadsack5000]

Ok i scrubbed the above and now have this:

Sub AddLogo_Click()Set Rng = Selection
fname = Application.GetOpenFilename("Picture files (*.jpg;*.gif;*.bmp), *.jpgs;*.gif;*.bmp", , _
            "Select the picture")
If fname = "False" Then Exit Sub
ActiveSheet.Pictures.Insert(fname).Select
     With Selection
        .ShapeRange.LockAspectRatio = msoTrue
        If (.Height \ .Width) <= (Rng.Height \ Rng.Width) Then
            .Width = Rng.Width - 1 'pictures' width is the larger height, by this line it fits exactly into range width
            .Left = Rng.Left + 1 'position at left range border
            .Top = Rng.Top + ((Rng.Height - Selection.Height) / 2) 'position in center of range height
        Else 'Picture's aspect is greater than rng aspect then adjust the picture's height to fit rng
            .Top = Rng.Top + 1 'position at upper border of the range
            .Height = Rng.Height - 1 'picture's heigth is larger than its width, this line makes it exactly fit int range height
            .Left = Rng.Left + ((Rng.Width - Selection.Width) / 2) 'position in center of range width
        End If
        
        .Placement = xlMoveAndSize
        .PrintObject = True 'make sure picture gets printed
        
    End With
End Sub

It at least enters the picture into the correct cell but the sizing is not correct, for landscape photos it fits to the width rather than the height and for portrait well i dont know what it does but it overlaps the cell edges up/down