Question

EXCEL vba插入自动调整图片

Sub 逐个导入图片()

Dim shp As Shape
Dim r As Integer
Dim fl As String '图片所在文件夹
Dim PicPath As String '图片名称所在目录
Dim Picrng As Range '图片导入单元格
'选择文件夹，默认是当前工作簿所在文件夹
With Application.FileDialog(msoFileDialogFilePicker)
.AllowMultiSelect = False
.Filters.Clear
'清除文件过滤器
.Filters.Add "图片文件", "*.jpg;*.jpeg;*.bmp;*.png"
.Filters.Add "All Files", "*.*"
If .Show = -1 Then
fl = .SelectedItems(1)
Else
Exit Sub
End If
End With
With ActiveSheet
PicPath = fl
If Dir(PicPath) <> "" Then
Set shp = .Shapes.AddPicture(PicPath, False, True, 0, 0, -1, -1)
Set Picrng = ActiveCell '设定图片插入单元格为活动单元格
With shp
.LockAspectRatio = msoFalse '纵横比可调整
.Top = Picrng.Top + 1
.Left = Picrng.Left + 1
.Width = Picrng.Width - 1.5
.Height = Picrng.Height - 1.5
End With
End If
End With
Set shp = Nothing
Set Picrng = Nothing
End Sub

像这个代码如何修改可以
①使插入的图片大小和位置随单元格而变
②使图片充满单元格而不是留一点缝隙

Answer 1

方法：

sub 图片导入
dim s as shape
dim rg as range
'删除已有的图片
for each s in activesheet.shapes
if s.type <> 8 then
s.delete
end if
'导入图片
for each rg in range("B2:B10")'这里放要插入图片的单元格范围 B2:B10可以改成你所需要的范围
activesheet.shapes.addshape(msoshaperectangle,rg.left,rg.top,rg.width,rg.height).select
selection.shaperange.fill.userpicture "E:\图片"& rg.offset(0, -1) & ".jpg"'这里指定的是图片的存储路径为E盘下的图片文件夹，然后图片名称与A列的数据一致，后缀名为JPG格式。这些你都可以自行更改。根据需要来定
next rg
end sub

Answer 2

这句 Set Picrng = ActiveCell 本身就是插入的图片大小和位置随单元格而变

不留缝隙该这几句如下：

.Top = Picrng.Top
.Left = Picrng.Left
.Width = Picrng.Width
.Height = Picrng.Height

追问

第二个问题解决了，但是第一个，插入的图片不会随单元格放大缩小或者隐藏而变化的，只能手动去图片属性里面去调整图片位置选项里面的 图片大小和位置随单元格而变，请问能通过Selection.Placement = xlFreeFloating类似的修改吗？代码不知道怎么加