添加图片需要引用文件路径的单元格并调整图像大小

Question

>我有一个addpicture VBA，它使用固定的文件路径运行文件，但我需要它来引用由特定单元格中的公式生成的文件路径。 还需要能够调整图像大小以适应单元格列宽，但保持纵横比。 我能够使用PictureInsert功能完成所有这些操作，但是当其他方使用文档时，图像不可见...

这是我的添加图片代码：

Sub URLAddPicture()
Set pic = ActiveSheet.Shapes.AddPicture("\frb-fs01DFSHOEPICS1. SHOE PHOTOSspring summer 2020BULK SAMPLESDISCOVERYAADLIA-SUBLACKEURO LEATHER.JPG", _
linktofile:=msoFalse, savewithdocument:=msoCTrue, Left:=0, Top:=0, Width:=-1, Height:=-1)
End Sub

和图片插入代码：

Sub URLPictureInsert()
Dim Pshp As Shape
Dim xRg As Range
Dim xCol As Long
On Error Resume Next
Application.ScreenUpdating = False
Set rng = ActiveSheet.Range("A113")
For Each cell In rng
filenam = cell
ActiveSheet.Pictures.Insert(filenam).Select
Set Pshp = Selection.ShapeRange.Item(1)
If Pshp Is Nothing Then GoTo lab
xCol = cell.Column
Set xRg = Cells(cell.Row, xCol)
With Selection
.ShapeRange.LockAspectRatio = msoTrue
If (.Height  .Width) <= (rng.Height  rng.Width) Then
.Width = rng.Width - 1
.Left = rng.Left + 1
.Top = rng.Top + ((rng.Height - Selection.Height) / 2)
Else
.Top = rng.Top + 1
.Height = rng.Height - 1
.Left = rng.Left + ((rng.Width - Selection.Width) / 2)
End If
.Placement = xlMoveAndSize
.PrintObject = True
End With
lab:
Set Pshp = Nothing
Range("A113").Select
Next
Application.ScreenUpdating = True
End Sub

如果有人能够提供帮助，我将不胜感激。

Answer 1

如果图片位于硬盘驱动器(磁盘(上的正确位置，并且rng是正确的，则此代码应该可以工作。 另外，如果rng是单个单元格，则无需循环，但是如果您将其变大，我保留了它以供以后使用......

Option Explicit
Sub URLPictureInsert()
Dim Pshp As Shape
Dim Cell As Range
Dim Rng As Range
Dim Filenam$
Application.ScreenUpdating = False
Set Rng = ActiveSheet.Range("A113")
For Each Cell In Rng
Filenam = Cell.Value2
On Error Resume Next 'in case filename doesn't exist
Set Pshp = ActiveSheet.Pictures.Insert(Filenam).ShapeRange(1)
On Error GoTo 0
If Not Pshp Is Nothing Then
With Pshp
.LockAspectRatio = msoTrue
If (.Height  .Width) <= (Rng.Height  Rng.Width) Then
.Width = Rng.Width - 1
.Left = Rng.Left + 1
.Top = Rng.Top + ((Rng.Height - .Height) / 2)
Else
.Top = Rng.Top + 1
.Height = Rng.Height - 1
.Left = Rng.Left + ((Rng.Width - .Width) / 2)
End If
.Placement = xlMoveAndSize
End With 'Pshp
End If 'not Pshp is nothing
Set Pshp = Nothing
Next Cell
Application.ScreenUpdating = True
End Sub