Excel 2016 vba Вставить и изменить размер изображения в диапазоне

Question

2 недели назад я создал код для вставки картинок, размещения их в диапазоне и изменения их размера до этого диапазона.Код работал безупречно, и я сгенерировал отчет на 100 страниц.

Сегодня я хочу снова запустить его в другом проекте, и картинки повсюду.Снимки с одной и той же камеры имеют одинаковое количество пикселей.

Я перепробовал множество вариантов, обсуждаемых на этом сайте, но ничего не работает.Я надеюсь, что кто-то может найти проблему.

Код:

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

Answer 1

Проблема в том, что ваши фотографии повернуты на 90 градусов.При доступе к свойствам положения и размера необходимо выполнить настройку для поворота, например,

Чтобы определить, поворачивается ли изображение, изучите свойство .ShapeRange.Rotation

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

Объяснениепочему это работает

Если у вас есть изображение со свойством Rotation! = 0, значения свойств Top, Left, Height, Width предназначены для не повернутого изображения.

Пример, если изображение выглядит так , и его свойство Rotation = 90 (или 270)

Затем его верх, налево, высота, шириназначения свойств фактически основаны на этом

Таким образом, чтобы расположить его над диапазоном, необходимо рассчитать размер изображения и положение на основе в позиции диапазона, но с учетом вращения, как показано в коде