Excel 2016 vba插入图片并调整图片大小以适应范围
Excel 2016 vba插入图片并调整图片大小以适应范围
提问于 2018-06-01 03:03:08
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
回答 1
Stack Overflow用户
发布于 2018-06-01 09:02:19
问题是你的照片被旋转了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解释为什么这是可行的
如果您有一张旋转属性为!= 0的图片，则Top、Left、Height、Width属性值用于未旋转的图像。
例如，如果图像如下所示，其旋转属性= 90 (或270)
则其Top、Left、Height、Width属性值实际上基于此
因此，要在某个范围内定位它，您需要根据范围位置计算图片大小和位置，但需要根据旋转进行调整，如代码所示
页面原文内容由Stack Overflow提供。腾讯云小微IT领域专用引擎提供翻译支持
原文链接：
https://stackoverflow.com/questions/50631128
复制相关文章
相似问题