image - Excel 2016 vba 将图片插入并调整大小到范围
问题描述
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
解决方案
问题是您的图片旋转了 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)
那么它的Top、Left、Height、Width属性值其实就是基于这个
因此,要将其定位在 Range 上,您需要根据range 位置计算图片大小和位置,但要针对旋转进行调整,如代码所示
推荐阅读
- reactjs - 如何在反应应用程序中使用oidc客户端进行身份验证后重定向
- mongodb - 如何从使用 MongoItemReader (Springbatch) 读取的对象中迭代列表
- asp.net-mvc - 客户端函数不调用
- c# - 传递函数
到 C# 中的 Task.Run() 而不使用 lambda 表达式 - scala - 如何在 Sonarqube 中创建新的 Scala 自定义规则并从 Sonarqube 服务器触发相同的规则?
- javascript - RxJs:通过 API 递归分页并从列表中查找值
- html - Jinja2 异常 - 找不到属性
- scala - Scala 类型推断和隐式转换
- node.js - 'react-scripts-ts' 未被识别为内部或外部命令
- java - 硬编码边界内的 ArrayIndexOutOfBoundsException