Shapes.AddPicture into cell

[dimitrilouwet]

We work with content exports that need validation. A picture helps, so we created a tool for this using ActiveSheet.Shapes.AddPicture
(ActiveSheet.Pictures.Insert is no good, because this only works on own computer)

On the first lines all seems ok. But after a given amount of rows, we see that the images are not inline with the cells anymore. See image enclosed.

Also note I use a fixed height of 40 here. Eventually the idea is to make this a variable input between 20 and 100.

Hope someone can point me in the right direction. Thanks in advance!

Private Sub InsertPictures()
    Dim objFile As String
    Dim strPath As String
    Dim lRow As Long
    Dim c As Long
    Dim rng As Range
    Dim sh As Shape

    With Application.FileDialog(msoFileDialogFolderPicker)
        If .Show = -1 Then
            strPath = .SelectedItems(1)
        End If
    End With

    If Right(strPath, 1) <> "\" Then strPath = strPath & "\"

    lRow = Cells(Rows.Count, Range("B3").Column).End(xlUp).Row + 1
   
Application.ScreenUpdating = False

c = 3

Do Until c = lRow
       
        If Cells(c, 2) = Empty Then
            GoTo 10
        Else
       
            'Where will picture go?
            Set rng = Cells(c, 3)
            objFile = strPath & Cells(c, 2).Value

            'Clear variable
            Set sh = Nothing
           
            On Error GoTo 10
            'Attempt to load picture. Note -1 means to use default
            Set sh = ActiveSheet.Shapes.AddPicture( _
                Filename:=objFile, _
                LinkToFile:=msoFalse, _
                SaveWithDocument:=msoTrue, _
                Left:=rng.Left + 2, _
                Top:=rng.Top + 2, _
                Width:=-1, _
                Height:=-1)
            On Error GoTo 0

            If Not sh Is Nothing Then
               
                'Lock ratios and resize height to fit cell
                sh.LockAspectRatio = msoCTrue
                sh.Height = 40 - 4
            End If
        End If
10:
    c = c + 1
    Loop
   
    Application.ScreenUpdating = True
    Range("A2").Select
   
End Sub

I'm sure this code can be much more elegant. Please note I'm just a novice vba user.

 

[RoryA]

If I remember correctly, that can happen if the window is zoomed to something other than 100%.

Also note that your error handler will only work for the first error.

 

[dimitrilouwet]

If I remember correctly, that can happen if the window is zoomed to something other than 100%.

Also note that your error handler will only work for the first error.

I was so fixed on the code itself that I did not consider other factors. Although after testing it seems that setting zoom to 100% does not solve the issue. See pciture enclosed.

And yes, here and there there are some sloppy bits in the code, my appologies.

Thanks!

 

[RoryA]

Which version and build of 365 do you have? Do you have the option to insert pictures into a cell directly?

 

[dimitrilouwet]

Which version and build of 365 do you have? Do you have the option to insert pictures into a cell directly?

Version 2312 (Build 17126.20190 Click-to-Run)

 

[dimitrilouwet]

Version 2312 (Build 17126.20190 Click-to-Run)

And when I click the info button I get a bit more info: Microsoft 365 MSO (Version 2312 Build 16.0.17126.20190) 64-bit

 

[RoryA]

You have the same version I do, so you don't yet have the option to insert them into cells sadly. I've just tested the code and it was still aligning pictures properly beyond row 500.

Do you have any scaling applied to text in your display settings in control panel, or is it set to 100%?

 

[dimitrilouwet]

I have three displays. Two of them had 100%, the third, my main had 125%. I have adjusted this now to 100%

And HoZaa, it works :D

I'm so happy this is solved. Now explain others in my organisation that they have to adjust there settings, gonna be a whole challenge in its own

Thanks a lot RoryA! I'm very greatful you helped me out with this!