Excel 2016 vba Insert and resize picture to range

Question

2 weeks ago I created a code to insert pictures, position them to a range and resize them to that range. The code worked flawlessly and I generated a 100 page report with it.

Today I want to run it again on another project and the pictures are all over the place. Pictures are from the same camera and have the same amount of pixels.

I have tried many options discussed on this site but nothing works. I hope someone can find the issue.

Code:

Dim ncellen As Integer              ' Teller voor te loopen
Public cpnummer As String        ' Keuze tussen klant nummer of onze nummer
Dim answer As String, Fotonaam As String, FotoPathOverview As String, FotoPathDetail As String, Counter As Integer, Counter2 As Integer, Counter3 As Integer
Dim sFout1 As String, sFout2 As String  'controle op foto's
Dim FotoOverview As Picture, FotoDetail As Picture, FotoLocatieOverview As String, FotoLocatieDetail As String, RangeOverview As Range, RangeDetail As Range   'Foto toevoegen
Dim ws As Worksheet, blnLeeg As Boolean

            // Loop starten
    Do While Cells(ncellen, 4) <> 0

'// Tabbladen aanmaken
        With Sheets("sjabloon")
            .Visible = True
            .Select
        End With
        Range("A1:N48").Select
        Selection.Copy
        Sheets.Add after:=Sheets(Worksheets.Count)
        Range("A:N").ColumnWidth = 6
        With ActiveSheet.PageSetup
            .PrintArea = "$A$1:$N$49"
            .Zoom = False
            .FitToPagesWide = 1
            .FitToPagesTall = 1
        End With
        Range("A1").Select
        ActiveSheet.Paste
        Application.CutCopyMode = False
        ActiveWindow.DisplayGridlines = False
        Fotonaam = Sheets("Te vervangen").Cells(ncellen, colNum17).Value
        FotoLocatieOverview = ActiveWorkbook.Path & "\Foto's\" & Fotonaam & "_O" & ".jpg"
        FotoLocatieDetail = ActiveWorkbook.Path & "\Foto's\" & Fotonaam & "_D" & ".jpg"

'//Foto's toevoegen
        If Dir(FotoLocatieOverview) = "" Then
            Cells(7, 1).Value = "No picture available"
            GoTo 2
        Else
            Set RangeOverview = Range(Cells(7, 1), Cells(20, 6))
            With RangeOverview
                Set FotoOverview = ActiveSheet.Pictures.Insert(FotoLocatieOverview)
                With FotoOverview
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Top = RangeOverview.Top
                    .Left = RangeOverview.Left
                    .Width = RangeOverview.Width
                    .Height = RangeOverview.Height
                End With
            End With
        End If
2:      'Jumppoint if there is no overview picture
        If Dir(FotoLocatieDetail) = "" Then
            GoTo 3
        Else
            Set RangeDetail = Range(Cells(7, 9), Cells(20, 14))
            With RangeDetail
                Set FotoDetail = ActiveSheet.Pictures.Insert(FotoLocatieDetail)
                With FotoDetail
                    .ShapeRange.LockAspectRatio = msoFalse
                    .Top = RangeDetail.Top
                    .Left = RangeDetail.Left
                    .Width = RangeDetail.Width
                    .Height = RangeDetail.Height
                End With
            End With
        End If

3:      'Jumppoint als er geen detail foto is
'// Cellen invullen
        Cells(4, 1) = Sheets("Te vervangen").Cells(ncellen, colNum)                      ' CP nummer
        Cells(23, 1) = Sheets("Te vervangen").Cells(ncellen, colNum1)                  ' Locatie
        Cells(26, 1) = Sheets("Te vervangen").Cells(ncellen, colNum2)                  ' Afdeling
        Cells(26, 3) = Sheets("Te vervangen").Cells(ncellen, colNum18)                ' Manifold nummer
        Cells(26, 6) = Sheets("Te vervangen").Cells(ncellen, colNum3)                  ' Plan nr
        Cells(26, 10) = Sheets("Te vervangen").Cells(ncellen, colNum4)                ' Niveau
        Cells(26, 12) = Sheets("Te vervangen").Cells(ncellen, colNum5)                ' Toepassing
        Cells(29, 1) = Sheets("Te vervangen").Cells(ncellen, colNum6)                  ' Type
        Cells(29, 4) = Sheets("Te vervangen").Cells(ncellen, colNum7)                  ' Merk
        Cells(29, 7) = Sheets("Te vervangen").Cells(ncellen, colNum8)                  ' Model
        Cells(29, 10) = Sheets("Te vervangen").Cells(ncellen, colNum11)              ' Diameter
        Cells(29, 12) = Sheets("Te vervangen").Cells(ncellen, colNum12)              ' Aansluiting
        Cells(32, 1) = Sheets("Te vervangen").Cells(ncellen, colNum9)                  ' Druk
        Cells(32, 4) = Sheets("Te vervangen").Cells(ncellen, colNum10)                ' Recuperatie
        Cells(32, 7) = Sheets("Te vervangen").Cells(ncellen, colNum13)                ' Montage
        Cells(32, 10) = Sheets("Te vervangen").Cells(ncellen, colNum14)              ' Status
        Cells(32, 12) = Sheets("Te vervangen").Cells(ncellen, colNum15)              ' Verlies (€/jr)
        Cells(36, 1) = Sheets("Te vervangen").Cells(ncellen, colNum16)                ' Remarks

'// Worksheet hernoemen
        ActiveSheet.Name = Range("A4").Value

'// Loop afwerken
        Sheets("Te vervangen").Select
        ncellen = ncellen + 1
    Loop

Sheets("sjabloon").Visible = False
1:
Application.ScreenUpdating = True

End Sub

screenshot

It's unclear what "the pictures are all over the place" means. Given that you are not [fully qualifying](https://stackoverflow.com/q/17733541/11683) the `Range`s and `Cells`, it might be because these ranges come not from the sheet you think, but that should not be a problem either because you do seem to want to work with the active sheet, unless there is code that is not shown that changes sheets when you don't expect it. — GSerg, May 31 '18 at 19:23
I've added a screenshot of what happens when I run the code. 90% of the pictures end up like this. But some of them also end up on the bottom of the page. And on very rare occasions the picture does end up resized in its proper location There is a lot more code but nothing in between here, no page switching is being done in between this. Like I said this code worked flawlessly but now it's a mess — Jens Damen, May 31 '18 at 19:38
Can you execute the code with F8 and see what happens after each step? — GSerg, May 31 '18 at 19:41
Tried it a couple of times and I think its the .Top = RangeDetail.Top .Left = RangeDetail.Left that doesn't do anything or atleast not what it's supposed to do. Set RangeDetail = Range(Cells(7, 9), Cells(20, 14)) : Is this correct? — Jens Damen, May 31 '18 at 19:45
And, now that we know what you are [actually trying to do](https://meta.stackexchange.com/q/66377/147640), I would say it would be much easier if you created two empty rectangle shapes where the pictures must be, saved that as a template, and then when creating a report page, assign a picture from file as a [texture background](https://superuser.com/q/1011249/52365) for that shape, without touching its size. — GSerg, May 31 '18 at 19:47
`Set RangeDetail = Range(Cells(7, 9), Cells(20, 14)) : Is this correct?` - yes, provided that the correct sheet is active during all that time, [otherwise no](https://stackoverflow.com/q/17733541/11683). — GSerg, May 31 '18 at 19:49
Ok thanks for the idea. I just tried it manually and it just turned my pictures 90°. When turning it again in the correct position the size was totally off and looked exactly like how it ends up with my macro. So I'm thinking the size of the picture is to blame to why it doesn't go to it's assigned location I updated the code to see the full page generating loop — Jens Damen, May 31 '18 at 19:59

chris neilsen · Answer 1 · 2018-06-03T01:56:14.043

The issue is that your pictures are rotated 90deg. When accessing the position and size properties, adjustment needs to be made for the rotation, like this

To determine if the image is rotated, examine the .ShapeRange.Rotation property

With FotoOverview
    .ShapeRange.LockAspectRatio = msoFalse
    If .ShapeRange.Rotation = 90! Or .ShapeRange.Rotation = 270! Then
        .Height = RangeOverview.Width
        .Width = RangeOverview.Height
        .Top = RangeOverview.Top - (.Height - .Width) / 2#
        .Left = RangeOverview.Left + (.Height - .Width) / 2#
    Else
        .Width = RangeOverview.Width
        .Height = RangeOverview.Height
        .Top = RangeOverview.Top
        .Left = RangeOverview.Left
    End If
End With

Explanation of why this works

If you have a picture with its Rotation property != 0, the Top, Left, Height, Width property values are for the un-rotated image.

Example if an image looks like this, and its Rotation property = 90 (or 270)

Then its Top, Left, Height, Width property values are actually based on this

So to position it over a Range, you need to calculate Picture size and position based on the range position but adjusted for the rotation, as shown in the code

This was the fix that was needed. After running the macro neither pictures were turned in any way but replacing my part with this part did snap them in place and all at the correct size. Don't understand why it's fixed but I'm happy :) — Jens Damen, Jun 01 '18 at 06:22

Excel 2016 vba Insert and resize picture to range

1 Answers1

Linked