Excel 2016 vba插入并调整图片大小到范围 [英] Excel 2016 vba Insert and resize picture to range

问题描述

2周前，我创建了一个代码来插入图片，将它们放置到一个范围内并将它们调整到该范围。
代码完美运行，我用它生成了一个100页的报告。

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.

代码：

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

推荐答案

问题是你的照片旋转90度。在访问位置和大小属性时，需要对旋转进行调整，例如

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

要确定图像是否旋转，请检查 .ShapeRange.Rotation property

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

说明为什么这样做

如果你有一张带有Rotation属性的图片！= 0，则Top，Left，Height，Width属性值适用于未旋转的图像。

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

如果图像看起来像这样的示例，其Rotation属性= 90（或270）

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

然后它的Top，Left，Height，Width属性值实际上是基于thi s

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

这篇关于Excel 2016 vba插入并调整图片大小到范围的文章就介绍到这了，希望我们推荐的答案对大家有所帮助，也希望大家多多支持IT屋！